From 2611e37f82b576a1366c2d78fce87c1a55852037 Mon Sep 17 00:00:00 2001 From: Emilia Lubecka Date: Fri, 23 Mar 2018 15:06:54 +0100 Subject: [PATCH] rename --- source/cluster/CMakeLists.txt | 85 +- source/cluster/clust_data.F90 | 74 + source/cluster/clust_data.f90 | 74 - source/cluster/cluster.F90 | 664 ++ source/cluster/cluster.f90 | 664 -- source/cluster/hc.F90 | 511 ++ source/cluster/hc.f90 | 511 -- source/cluster/io_clust.F90 | 1824 ++++ source/cluster/io_clust.f90 | 1824 ---- source/cluster/main_clust.F | 449 - source/cluster/probabl.F90 | 361 + source/cluster/probabl.f90 | 361 - source/cluster/track.F90 | 306 + source/cluster/track.f90 | 306 - source/unres/CMakeLists.txt | 132 +- source/unres/CSA.F90 | 5321 ++++++++++++ source/unres/CSA.f90 | 5321 ------------ source/unres/MCM_MD.F90 | 3514 ++++++++ source/unres/MCM_MD.f90 | 3514 -------- source/unres/MD.F90 | 5680 ++++++++++++ source/unres/MD.f90 | 5680 ------------ source/unres/MPI.F90 | 594 ++ source/unres/MPI.f90 | 594 -- source/unres/MREMD.F90 | 2024 +++++ source/unres/MREMD.f90 | 2024 ----- source/unres/REMD.F90 | 772 ++ source/unres/REMD.f90 | 772 -- source/unres/check_bond.F90 | 38 + source/unres/check_bond.f90 | 38 - source/unres/cinfo.F90 | 39 + source/unres/cinfo.f90 | 39 - source/unres/compare.F90 | 4 +- source/unres/control.F90 | 5 +- source/unres/data/CSA_data.F90 | 77 + source/unres/data/CSA_data.f90 | 77 - source/unres/data/MCM_data.F90 | 73 + source/unres/data/MCM_data.f90 | 73 - source/unres/data/MD_data.F90 | 100 + source/unres/data/MD_data.f90 | 100 - source/unres/data/MPI_data.F90 | 54 + source/unres/data/MPI_data.f90 | 54 - source/unres/data/REMD_data.F90 | 26 + source/unres/data/REMD_data.f90 | 26 - source/unres/data/calc_data.F90 | 14 + source/unres/data/calc_data.f90 | 14 - source/unres/data/comm_local.F90 | 103 + source/unres/data/comm_local.f90 | 103 - source/unres/data/compare_data.F90 | 51 + source/unres/data/compare_data.f90 | 51 - source/unres/data/control_data.F90 | 92 + source/unres/data/control_data.f90 | 92 - source/unres/data/energy_data.F90 | 278 + source/unres/data/energy_data.f90 | 278 - source/unres/data/geometry_data.F90 | 60 + source/unres/data/geometry_data.f90 | 60 - source/unres/data/io_units.F90 | 71 + source/unres/data/io_units.f90 | 71 - source/unres/data/map_data.F90 | 10 + source/unres/data/map_data.f90 | 10 - source/unres/data/minim_data.F90 | 13 + source/unres/data/minim_data.f90 | 13 - source/unres/data/names.F90 | 66 + source/unres/data/names.f90 | 66 - source/unres/energy.F90 |16248 +++++++++++++++++++++++++++++++++++ source/unres/energy.f90 |16248 ----------------------------------- source/unres/geometry.F90 | 3597 ++++++++ source/unres/geometry.f90 | 3597 -------- source/unres/io.F90 | 1340 +++ source/unres/io.f90 | 1340 --- source/unres/io_base.F90 | 1326 +++ source/unres/io_base.f90 | 1326 --- source/unres/io_config.F90 | 4252 +++++++++ source/unres/io_config.f90 | 4252 --------- source/unres/map.F90 | 191 + source/unres/map.f90 | 191 - source/unres/math.F90 | 834 ++ source/unres/math.f90 | 834 -- source/unres/md_calc.F90 | 3365 ++++++++ source/unres/md_calc.f90 | 3365 -------- source/unres/minim.F90 | 6508 ++++++++++++++ source/unres/minim.f90 | 6508 -------------- source/unres/muca_md.F90 | 389 + source/unres/muca_md.f90 | 389 - source/unres/prng.F90 | 538 ++ source/unres/prng.f90 | 538 -- source/unres/prng_32.F90 | 1102 +++ source/unres/prng_32.f90 | 1102 --- source/unres/random.F90 | 577 ++ source/unres/random.f90 | 577 -- source/unres/regularize.F90 | 510 ++ source/unres/regularize.f90 | 510 -- source/unres/unres.F90 | 1055 +++ source/unres/unres.f90 | 1055 --- source/wham/CMakeLists.txt | 92 +- source/wham/cinfo.F90 | 38 + source/wham/cinfo.f90 | 38 - source/wham/conform_compar.F90 | 3559 ++++++++ source/wham/conform_compar.f90 | 3559 -------- source/wham/control_wham.F90 | 290 + source/wham/control_wham.f90 | 290 - source/wham/enecalc.F90 | 1708 ++++ source/wham/enecalc.f90 | 1708 ---- source/wham/io_database.F90 | 1488 ++++ source/wham/io_database.f90 | 1488 ---- source/wham/io_wham.F90 | 2765 ++++++ source/wham/io_wham.f90 | 2765 ------ source/wham/w_comm_local.F90 | 9 + source/wham/w_comm_local.f90 | 9 - source/wham/w_compar_data.F90 | 55 + source/wham/w_compar_data.f90 | 55 - source/wham/wham.F90 | 372 + source/wham/wham.f90 | 372 - source/wham/wham_calc.F90 | 1259 +++ source/wham/wham_calc.f90 | 1259 --- source/wham/wham_data.F90 | 132 + source/wham/wham_data.f90 | 132 - source/wham/work_partition.F90 | 127 + source/wham/work_partition.f90 | 127 - 118 files changed, 76603 insertions(+), 77052 deletions(-) create mode 100644 source/cluster/clust_data.F90 delete mode 100644 source/cluster/clust_data.f90 create mode 100644 source/cluster/cluster.F90 delete mode 100644 source/cluster/cluster.f90 create mode 100644 source/cluster/hc.F90 delete mode 100644 source/cluster/hc.f90 create mode 100644 source/cluster/io_clust.F90 delete mode 100644 source/cluster/io_clust.f90 delete mode 100644 source/cluster/main_clust.F create mode 100644 source/cluster/probabl.F90 delete mode 100644 source/cluster/probabl.f90 create mode 100644 source/cluster/track.F90 delete mode 100644 source/cluster/track.f90 create mode 100644 source/unres/CSA.F90 delete mode 100644 source/unres/CSA.f90 create mode 100644 source/unres/MCM_MD.F90 delete mode 100644 source/unres/MCM_MD.f90 create mode 100644 source/unres/MD.F90 delete mode 100644 source/unres/MD.f90 create mode 100644 source/unres/MPI.F90 delete mode 100644 source/unres/MPI.f90 create mode 100644 source/unres/MREMD.F90 delete mode 100644 source/unres/MREMD.f90 create mode 100644 source/unres/REMD.F90 delete mode 100644 source/unres/REMD.f90 create mode 100644 source/unres/check_bond.F90 delete mode 100644 source/unres/check_bond.f90 create mode 100644 source/unres/cinfo.F90 delete mode 100644 source/unres/cinfo.f90 create mode 100644 source/unres/data/CSA_data.F90 delete mode 100644 source/unres/data/CSA_data.f90 create mode 100644 source/unres/data/MCM_data.F90 delete mode 100644 source/unres/data/MCM_data.f90 create mode 100644 source/unres/data/MD_data.F90 delete mode 100644 source/unres/data/MD_data.f90 create mode 100644 source/unres/data/MPI_data.F90 delete mode 100644 source/unres/data/MPI_data.f90 create mode 100644 source/unres/data/REMD_data.F90 delete mode 100644 source/unres/data/REMD_data.f90 create mode 100644 source/unres/data/calc_data.F90 delete mode 100644 source/unres/data/calc_data.f90 create mode 100644 source/unres/data/comm_local.F90 delete mode 100644 source/unres/data/comm_local.f90 create mode 100644 source/unres/data/compare_data.F90 delete mode 100644 source/unres/data/compare_data.f90 create mode 100644 source/unres/data/control_data.F90 delete mode 100644 source/unres/data/control_data.f90 create mode 100644 source/unres/data/energy_data.F90 delete mode 100644 source/unres/data/energy_data.f90 create mode 100644 source/unres/data/geometry_data.F90 delete mode 100644 source/unres/data/geometry_data.f90 create mode 100644 source/unres/data/io_units.F90 delete mode 100644 source/unres/data/io_units.f90 create mode 100644 source/unres/data/map_data.F90 delete mode 100644 source/unres/data/map_data.f90 create mode 100644 source/unres/data/minim_data.F90 delete mode 100644 source/unres/data/minim_data.f90 create mode 100644 source/unres/data/names.F90 delete mode 100644 source/unres/data/names.f90 create mode 100644 source/unres/energy.F90 delete mode 100644 source/unres/energy.f90 create mode 100644 source/unres/geometry.F90 delete mode 100644 source/unres/geometry.f90 create mode 100644 source/unres/io.F90 delete mode 100644 source/unres/io.f90 create mode 100644 source/unres/io_base.F90 delete mode 100644 source/unres/io_base.f90 create mode 100644 source/unres/io_config.F90 delete mode 100644 source/unres/io_config.f90 create mode 100644 source/unres/map.F90 delete mode 100644 source/unres/map.f90 create mode 100644 source/unres/math.F90 delete mode 100644 source/unres/math.f90 create mode 100644 source/unres/md_calc.F90 delete mode 100644 source/unres/md_calc.f90 create mode 100644 source/unres/minim.F90 delete mode 100644 source/unres/minim.f90 create mode 100644 source/unres/muca_md.F90 delete mode 100644 source/unres/muca_md.f90 create mode 100644 source/unres/prng.F90 delete mode 100644 source/unres/prng.f90 create mode 100644 source/unres/prng_32.F90 delete mode 100644 source/unres/prng_32.f90 create mode 100644 source/unres/random.F90 delete mode 100644 source/unres/random.f90 create mode 100644 source/unres/regularize.F90 delete mode 100644 source/unres/regularize.f90 create mode 100644 source/unres/unres.F90 delete mode 100644 source/unres/unres.f90 create mode 100644 source/wham/cinfo.F90 delete mode 100644 source/wham/cinfo.f90 create mode 100644 source/wham/conform_compar.F90 delete mode 100644 source/wham/conform_compar.f90 create mode 100644 source/wham/control_wham.F90 delete mode 100644 source/wham/control_wham.f90 create mode 100644 source/wham/enecalc.F90 delete mode 100644 source/wham/enecalc.f90 create mode 100644 source/wham/io_database.F90 delete mode 100644 source/wham/io_database.f90 create mode 100644 source/wham/io_wham.F90 delete mode 100644 source/wham/io_wham.f90 create mode 100644 source/wham/w_comm_local.F90 delete mode 100644 source/wham/w_comm_local.f90 create mode 100644 source/wham/w_compar_data.F90 delete mode 100644 source/wham/w_compar_data.f90 create mode 100644 source/wham/wham.F90 delete mode 100644 source/wham/wham.f90 create mode 100644 source/wham/wham_calc.F90 delete mode 100644 source/wham/wham_calc.f90 create mode 100644 source/wham/wham_data.F90 delete mode 100644 source/wham/wham_data.f90 create mode 100644 source/wham/work_partition.F90 delete mode 100644 source/wham/work_partition.f90 diff --git a/source/cluster/CMakeLists.txt b/source/cluster/CMakeLists.txt index 7f814c1..0281f62 100644 --- a/source/cluster/CMakeLists.txt +++ b/source/cluster/CMakeLists.txt @@ -8,36 +8,36 @@ enable_language (Fortran) # Set source file lists #================================ set(UNRES_CLUSTER_WHAM_SRC0 - clust_data.f90 - ../wham/wham_data.f90 - ../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/energy_data.f90 - ../unres/data/geometry_data.f90 - ../unres/data/map_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 + clust_data.F90 + ../wham/wham_data.F90 + ../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/energy_data.F90 + ../unres/data/geometry_data.F90 + ../unres/data/map_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 - ../wham/io_wham.f90 - ../wham/conform_compar.f90 - ../wham/work_partition.f90 - probabl.f90 - track.f90 - hc.f90 - io_clust.f90 - cluster.f90 + ../unres/io_config.F90 + ../unres/regularize.F90 + ../wham/io_wham.F90 + ../wham/conform_compar.F90 + ../wham/work_partition.F90 + probabl.F90 + track.F90 + hc.F90 + io_clust.F90 + cluster.F90 ) @@ -199,23 +199,22 @@ 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_ext.parm -export THETPAR=$DD/theta_abinitio_old_ext.parm -export THETPARPDB=$DD/thetaml_ext.5parm -export ROTPARPDB=$DD/scgauss_ext.parm -export ROTPAR=$DD/rotamers_AM1_aura_ext.10022007.parm -export TORPAR=$DD/torsion_631Gdp_old_ext.parm -export TORDPAR=$DD/torsion_double_631Gdp_old_ext.parm -export ELEPAR=$DD/electr_631Gdp_ext.parm -export SIDEPAR=$DD/scinter_GB_ext.parm -export FOURIER=$DD/fourier_opt_ext.parm.1igd_hc_iter3_3 -export SCCORPAR=$DD/sccor_am1_pawel_ext.dat -export SCPPAR=$DD/scp_ext.parm +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_ext.3.parm +export SIDEP=$DD/contact.3.parm export SCRATCHDIR=. - #----------------------------------------------------------------------------- echo CTEST_FULL_OUTPUT ${mpiexec} ${boot_lam} ${np} $2 $CLUSTER_WHAM_BIN diff --git a/source/cluster/clust_data.F90 b/source/cluster/clust_data.F90 new file mode 100644 index 0000000..2fdba69 --- /dev/null +++ b/source/cluster/clust_data.F90 @@ -0,0 +1,74 @@ + module clust_data +!----------------------------------------------------------------------------- +!***************************************************************** +! +! Array dimensions for the clustering programs: +! +! Max. number of conformations in the data set. +! + integer,PARAMETER :: MAXCONF=13000 + integer,parameter :: maxstr_proc=maxconf +! +! Max. number of "distances" between conformations. +! + integer,PARAMETER :: MAXDIST=(maxstr_proc*(maxstr_proc-1))/2 +! +! Max. number of clusters. Should be set to MAXCONF; change only if there are +! problems with memory. In such a case be suspicious about the results, however! +! + integer,PARAMETER :: MAXGR=maxstr_proc +! +! Max. number of conformations in a cluster. Remark above applies also here. +! + integer,PARAMETER :: MAXINGR=maxstr_proc +! +! Max. number of cut-off values +! + integer,PARAMETER :: MAX_CUT=5 +! +! Max. number of properties +! + integer,PARAMETER :: MAXPROP=5 +! +! Max. number of temperatures + integer,parameter :: maxT=5 +! +! Max. number of S-S bridges + integer,parameter :: maxss=20 +! +!****************************************************************** +!COMMON.CLUSTER +! common /clu/ + real(kind=4),dimension(:),allocatable :: diss !(maxdist) + real(kind=8),dimension(:),allocatable :: energy,totfree !(0:maxconf) + real(kind=8),dimension(:,:),allocatable :: enetb !(max_ene,maxstr_proc) + real(kind=8),dimension(:),allocatable :: entfac !(maxconf) + real(kind=8),dimension(:),allocatable :: totfree_gr !(maxgr) + real(kind=8),dimension(:),allocatable :: rcutoff !(max_cut+1) + real(kind=8) :: ecut + integer :: ncut + logical :: min_var,tree,plot_tree,lgrp +! common /clu1/ + integer,dimension(:),allocatable :: licz,iass !(maxgr) + integer,dimension(:,:),allocatable :: nconf !(maxgr,maxingr) + integer,dimension(:,:),allocatable :: iass_tot !(maxgr,max_cut) + integer,dimension(:),allocatable :: list_conf !(maxconf) + integer :: ngr +! common /alles/ + real(kind=4),dimension(:,:,:),allocatable :: allcart !(3,maxres2,maxstr_proc) + real(kind=8),dimension(:),allocatable :: rmstb !(maxconf) + integer,dimension(:),allocatable :: mult !(maxres) + integer,dimension(:),allocatable :: nss_all !(maxstr_proc) + integer,dimension(:,:),allocatable :: ihpb_all,jhpb_all !(maxss,maxstr_proc) + integer,dimension(:),allocatable :: icc,iscore !(maxconf) + integer :: nprop +!COMMON.TEMPFAC +! common /factemp/ + real(kind=8),dimension(:,:),allocatable :: tempfac !(2,maxres) +!COMMON.FREE +! common /free/ + integer :: nT + real(kind=8) :: prob_limit + real(kind=8),dimension(:),allocatable :: beta_h !(maxT) +!----------------------------------------------------------------------------- + end module clust_data diff --git a/source/cluster/clust_data.f90 b/source/cluster/clust_data.f90 deleted file mode 100644 index 2fdba69..0000000 --- a/source/cluster/clust_data.f90 +++ /dev/null @@ -1,74 +0,0 @@ - module clust_data -!----------------------------------------------------------------------------- -!***************************************************************** -! -! Array dimensions for the clustering programs: -! -! Max. number of conformations in the data set. -! - integer,PARAMETER :: MAXCONF=13000 - integer,parameter :: maxstr_proc=maxconf -! -! Max. number of "distances" between conformations. -! - integer,PARAMETER :: MAXDIST=(maxstr_proc*(maxstr_proc-1))/2 -! -! Max. number of clusters. Should be set to MAXCONF; change only if there are -! problems with memory. In such a case be suspicious about the results, however! -! - integer,PARAMETER :: MAXGR=maxstr_proc -! -! Max. number of conformations in a cluster. Remark above applies also here. -! - integer,PARAMETER :: MAXINGR=maxstr_proc -! -! Max. number of cut-off values -! - integer,PARAMETER :: MAX_CUT=5 -! -! Max. number of properties -! - integer,PARAMETER :: MAXPROP=5 -! -! Max. number of temperatures - integer,parameter :: maxT=5 -! -! Max. number of S-S bridges - integer,parameter :: maxss=20 -! -!****************************************************************** -!COMMON.CLUSTER -! common /clu/ - real(kind=4),dimension(:),allocatable :: diss !(maxdist) - real(kind=8),dimension(:),allocatable :: energy,totfree !(0:maxconf) - real(kind=8),dimension(:,:),allocatable :: enetb !(max_ene,maxstr_proc) - real(kind=8),dimension(:),allocatable :: entfac !(maxconf) - real(kind=8),dimension(:),allocatable :: totfree_gr !(maxgr) - real(kind=8),dimension(:),allocatable :: rcutoff !(max_cut+1) - real(kind=8) :: ecut - integer :: ncut - logical :: min_var,tree,plot_tree,lgrp -! common /clu1/ - integer,dimension(:),allocatable :: licz,iass !(maxgr) - integer,dimension(:,:),allocatable :: nconf !(maxgr,maxingr) - integer,dimension(:,:),allocatable :: iass_tot !(maxgr,max_cut) - integer,dimension(:),allocatable :: list_conf !(maxconf) - integer :: ngr -! common /alles/ - real(kind=4),dimension(:,:,:),allocatable :: allcart !(3,maxres2,maxstr_proc) - real(kind=8),dimension(:),allocatable :: rmstb !(maxconf) - integer,dimension(:),allocatable :: mult !(maxres) - integer,dimension(:),allocatable :: nss_all !(maxstr_proc) - integer,dimension(:,:),allocatable :: ihpb_all,jhpb_all !(maxss,maxstr_proc) - integer,dimension(:),allocatable :: icc,iscore !(maxconf) - integer :: nprop -!COMMON.TEMPFAC -! common /factemp/ - real(kind=8),dimension(:,:),allocatable :: tempfac !(2,maxres) -!COMMON.FREE -! common /free/ - integer :: nT - real(kind=8) :: prob_limit - real(kind=8),dimension(:),allocatable :: beta_h !(maxT) -!----------------------------------------------------------------------------- - end module clust_data diff --git a/source/cluster/cluster.F90 b/source/cluster/cluster.F90 new file mode 100644 index 0000000..1b6767c --- /dev/null +++ b/source/cluster/cluster.F90 @@ -0,0 +1,664 @@ + program cluster +! +! Program to cluster united-residue MCM results. +! + use clust_data + use probability + use tracking + use hc_ + use io_clust +!#define CLUSTER + use io_units + use io_base, only: permut + use geometry_data, only: nres,theta,phi,alph,omeg,& + c,cref + use energy_data, only: nnt,nct + use control_data, only: symetr,outpdb,outmol2,titel,& + iopt,print_dist,MaxProcs + use control, only: tcpu,initialize + + use wham_data, only: punch_dist + use io_wham, only: parmread + use work_part +! include 'DIMENSIONS' +! include 'sizesclu.dat' +#ifdef MPI + use mpi_data + implicit none + include "mpif.h" + integer :: IERROR,ERRCODE !STATUS(MPI_STATUS_SIZE) +#else + implicit none +! include "COMMON.MPI" +#endif +! include 'COMMON.TIME1' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.CLUSTER' +! include 'COMMON.IOUNITS' +! include 'COMMON.FREE' + + logical,dimension(:),allocatable :: printang !(max_cut) + integer,dimension(:),allocatable :: printpdb !(max_cut) + integer,dimension(:),allocatable :: printmol2 !(max_cut) + character(len=240) lineh + REAL(kind=4),dimension(:),allocatable :: CRIT,MEMBR !(maxconf) + REAL(kind=4),dimension(:),allocatable :: CRITVAL !(maxconf-1) + INTEGER,dimension(:),allocatable :: IA,IB !(maxconf) + INTEGER,dimension(:,:),allocatable :: ICLASS !(maxconf,maxconf-1) + INTEGER,dimension(:),allocatable :: HVALS !(maxconf-1) + INTEGER,dimension(:),allocatable :: IORDER,HEIGHT !(maxconf-1) + integer,dimension(:),allocatable :: nn !(maxconf) + integer :: ndis + real(kind=4),dimension(:),allocatable :: DISNN !(maxconf) + LOGICAL,dimension(:),allocatable :: FLAG !(maxconf) + integer :: i,j,k,l,m,n,len,lev,idum,ii,ind,jj,icut,ncon,& + it,ncon_work,ind1,kkk + real(kind=8) :: t1,t2,difconf + + real(kind=8),dimension(:),allocatable :: varia !(maxvar) + real(kind=8),dimension(:),allocatable :: list_conf_ !(maxvar) + real(kind=8) :: hrtime,mintime,sectime + logical :: eof + external :: difconf +!el + real(kind=4),dimension(:),allocatable :: diss_ !(maxdist) + integer,dimension(:),allocatable :: scount_ !(maxdist) +#ifdef MPI + call MPI_Init( IERROR ) + call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR ) + call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR ) + Master = 0 + if (ierror.gt.0) then + write(iout,*) "SEVERE ERROR - Can't initialize MPI." + call mpi_finalize(ierror) + stop + endif + if (nprocs.gt.MaxProcs+1) then + write (2,*) "Error - too many processors",& + nprocs,MaxProcs+1 + write (2,*) "Increase MaxProcs and recompile" + call MPI_Finalize(IERROR) + stop + endif +#endif +!elwrite(iout,*) "before parmread" + allocate(printang(max_cut)) + allocate(printpdb(max_cut)) + allocate(printmol2(max_cut)) + call initialize +!elwrite(iout,*) "before parmread" + call openunits +!elwrite(iout,*) "before parmread" + call parmread + call read_control +!elwrite(iout,*) "after read control" + call molread +! if (refstr) call read_ref_structure(*30) + do i=1,nres + phi(i)=0.0D0 + theta(i)=0.0D0 + alph(i)=0.0D0 + omeg(i)=0.0D0 + enddo +! write (iout,*) "Before permut" +! write (iout,*) "symetr", symetr +! call flush(iout) + call permut(symetr) +! write (iout,*) "after permut" +! call flush(iout) + print *,'MAIN: nnt=',nnt,' nct=',nct + + DO I=1,NCUT + PRINTANG(I)=.FALSE. + PRINTPDB(I)=0 + printmol2(i)=0 + IF (RCUTOFF(I).LT.0.0) THEN + RCUTOFF(I)=ABS(RCUTOFF(I)) + PRINTANG(I)=.TRUE. + PRINTPDB(I)=outpdb + printmol2(i)=outmol2 + ENDIF + ENDDO + write (iout,*) 'Number of cutoffs:',NCUT + write (iout,*) 'Cutoff values:' + DO ICUT=1,NCUT + WRITE(IOUT,'(8HRCUTOFF(,I2,2H)=,F8.1,2i2)')ICUT,RCUTOFF(ICUT),& + printpdb(icut),printmol2(icut) + ENDDO + DO I=1,NRES-3 + MULT(I)=1 + ENDDO + allocate(list_conf(maxconf)) + do i=1,maxconf + list_conf(i)=i + enddo + call read_coords(ncon,*20) + + allocate(list_conf_(maxconf)) + do i=1,maxconf + list_conf_(i)=list_conf(i) + enddo + deallocate(list_conf) + allocate(list_conf(ncon)) + do i=1,ncon + list_conf(i)=list_conf_(i) + enddo + deallocate(list_conf_) + +!el call alloc_clust_arrays(ncon) + + write (iout,*) 'from read_coords: ncon',ncon + + write (iout,*) "nT",nT + do iT=1,nT + write (iout,*) "iT",iT +#ifdef MPI + call work_partition(.true.,ncon) +#endif +!elwrite(iout,*)"after work partition, ncon_work=", ncon_work,ncon + + call probabl(iT,ncon_work,ncon,*20) + +!elwrite(iout,*)"after probabl, ncon_work=", ncon_work,ncon + + if (ncon_work.lt.2) then + write (iout,*) "Too few conformations; clustering skipped" + exit + endif +#ifdef MPI + ndis=ncon_work*(ncon_work-1)/2 + call work_partition(.true.,ndis) +#endif +!el call alloc_clust_arrays(ncon_work) + allocate(ICC(ncon_work)) + allocate(DISS(maxdist)) + + DO I=1,NCON_work + ICC(I)=I + ENDDO + WRITE (iout,'(A80)') TITEL + t1=tcpu() +! +! CALCULATE DISTANCES +! + call daread_ccoords(1,ncon_work) + ind1=0 + DO I=1,NCON_work-1 + if (mod(i,100).eq.0) print *,'Calculating RMS i=',i + do k=1,2*nres + do l=1,3 + c(l,k)=allcart(l,k,i) + enddo + enddo + kkk=1 + do k=1,nres + do l=1,3 + cref(l,k,kkk)=c(l,k) + enddo + enddo + DO J=I+1,NCON_work + IND=IOFFSET(NCON_work,I,J) +#ifdef MPI + if (ind.ge.indstart(me) .and. ind.le.indend(me)) then +#endif + ind1=ind1+1 + DISS(IND1)=DIFCONF(I,J) +! write (iout,'(2i4,i10,f10.5)') i,j,ind,DISS(IND) +#ifdef MPI + endif +#endif + ENDDO + ENDDO + t2=tcpu() + WRITE (iout,'(/a,1pe14.5,a/)') & + 'Time for distance calculation:',T2-T1,' sec.' + t1=tcpu() + PRINT '(a)','End of distance computation' +!el--------------- + allocate(diss_(maxdist)) + allocate(scount_(0:nprocs)) + + do i=1,maxdist + diss_(i)=diss(i) + enddo + do i=0,nprocs + scount_(i)=scount(i) + enddo +!el----------- +#ifdef MPI + call MPI_Gatherv(diss_(1),scount_(me),MPI_REAL,diss(1),& + scount(0),idispl(0),MPI_REAL,Master,MPI_COMM_WORLD, IERROR) + if (me.eq.master) then +#endif + deallocate(diss_) + deallocate(scount_) + + open(80,file='/tmp/distance',form='unformatted') + do i=1,ndis + write(80) diss(i) + enddo + if (punch_dist) then + do i=1,ncon_work-1 + do j=i+1,ncon_work + IND=IOFFSET(NCON,I,J) + write (jrms,'(2i5,2f10.5)') i,j,diss(IND),& + energy(j)-energy(i) + enddo + enddo + endif +! +! Print out the RMS deviation matrix. +! + if (print_dist) CALL DISTOUT(NCON_work) +! +! call hierarchical clustering HC from F. Murtagh +! + N=NCON_work + LEN = (N*(N-1))/2 + write(iout,*) "-------------------------------------------" + write(iout,*) "HIERARCHICAL CLUSTERING using" + if (iopt.eq.1) then + write(iout,*) "WARD'S MINIMUM VARIANCE METHOD" + elseif (iopt.eq.2) then + write(iout,*) "SINGLE LINK METHOD" + elseif (iopt.eq.3) then + write(iout,*) "COMPLETE LINK METHOD" + elseif (iopt.eq.4) then + write(iout,*) "AVERAGE LINK (OR GROUP AVERAGE) METHOD" + elseif (iopt.eq.5) then + write(iout,*) "MCQUITTY'S METHOD" + elseif (iopt.eq.6) then + write(iout,*) "MEDIAN (GOWER'S) METHOD" + elseif (iopt.eq.7) then + write(iout,*) "CENTROID METHOD" + else + write(iout,*) "IOPT=",iopt," IS INVALID, use 1-7" + write(*,*) "IOPT=",iopt," IS INVALID, use 1-7" + stop + endif + write(iout,*) + write(iout,*) "hc.f by F. Murtagh, ESA/ESO/STECF, Garching" + write(iout,*) "February 1986" + write(iout,*) "References:" + write(iout,*) "1. Multidimensional clustering algorithms" + write(iout,*) " Fionn Murtagh" + write(iout,*) " Vienna : Physica-Verlag, 1985." + write(iout,*) "2. Multivariate data analysis" + write(iout,*) " Fionn Murtagh and Andre Heck" + write(iout,*) " Kluwer Academic Publishers, 1987" + write(iout,*) "-------------------------------------------" + write(iout,*) + +#ifdef DEBUG + write (iout,*) "The TOTFREE array" + do i=1,ncon_work + write (iout,'(2i5,f10.5)') i,list_conf(i),totfree(i) + enddo +#endif + allocate(CRIT(N),MEMBR(N)) !(maxconf) + allocate(CRITVAL(N-1)) !(maxconf-1) + allocate(IA(N),IB(N)) + allocate(ICLASS(N,N-1)) !(maxconf,maxconf-1) + allocate(HVALS(N-1)) !(maxconf-1) + allocate(IORDER(N-1),HEIGHT(N-1)) !(maxconf-1) + allocate(nn(N)) !(maxconf) + allocate(DISNN(N)) !(maxconf) + allocate(FLAG(N)) !(maxconf) + + call flush(iout) + CALL HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,DISS) + LEV = N-1 + write (iout,*) "n",n," ncon_work",ncon_work," lev",lev + if (lev.lt.2) then + write (iout,*) "Too few conformations to cluster." + goto 192 + endif + CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT) +! CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL) + + allocate(licz(maxgr)) + allocate(iass(maxgr)) + allocate(nconf(maxgr,maxingr)) + allocate(totfree_gr(maxgr)) + + do i=1,maxgr + licz(i)=0 + enddo + icut=1 + i=1 + NGR=i+1 + do j=1,n + licz(iclass(j,i))=licz(iclass(j,i))+1 + nconf(iclass(j,i),licz(iclass(j,i)))=j +! write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)), +! & nconf(iclass(j,i),licz(iclass(j,i))) + enddo + do i=1,lev-1 + + idum=lev-i + DO L=1,LEV + IF (HEIGHT(L).EQ.IDUM) GOTO 190 + ENDDO + 190 IDUM=L + write(IOUT,*) "i+1",i+1," idum",idum," critval",CRITVAL(IDUM),& + " icut",icut," cutoff",rcutoff(icut) + IF (CRITVAL(IDUM).LT. RCUTOFF(ICUT)) THEN + WRITE (iout,'(/a,f10.5)') 'AT CUTOFF:',rcutoff(icut) + write (iout,'(a,f8.2)') 'Maximum distance found:',& + CRITVAL(IDUM) + CALL SRTCLUST(ICUT,ncon_work,iT) + CALL TRACK(ICUT) + CALL WRTCLUST(ncon_work,ICUT,PRINTANG,PRINTPDB,PRINTMOL2,iT) + icut=icut+1 + if (icut.gt.ncut) goto 191 + ENDIF + NGR=i+1 + do l=1,maxgr + licz(l)=0 + enddo + do j=1,n + enddo + do j=1,n + licz(iclass(j,i))=licz(iclass(j,i))+1 + nconf(iclass(j,i),licz(iclass(j,i)))=j +!d write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)),& +!d nconf(iclass(j,i),licz(iclass(j,i))) +!d print *,j,iclass(j,i), +!d & licz(iclass(j,i)),nconf(iclass(j,i),licz(iclass(j,i))) + enddo + enddo + 191 continue +! + if (plot_tree) then + CALL WRITRACK + CALL PLOTREE + endif +! + t2=tcpu() + WRITE (iout,'(/a,1pe14.5,a/)') & + 'Total time for clustering:',T2-T1,' sec.' +#ifdef MPI + endif +#endif + 192 continue + enddo +! + close(icbase,status="delete") +#ifdef MPI +!el call MPI_Finalize(MPI_COMM_WORLD,IERROR) + call MPI_Finalize(IERROR) +#endif + stop '********** Program terminated normally.' + 20 write (iout,*) "Error reading coordinates" +#ifdef MPI +!el call MPI_Finalize(MPI_COMM_WORLD,IERROR) + call MPI_Finalize(IERROR) +#endif + stop + 30 write (iout,*) "Error reading reference structure" +#ifdef MPI +!el call MPI_Finalize(MPI_COMM_WORLD,IERROR) + call MPI_Finalize(IERROR) +#endif + stop + end program cluster +!--------------------------------------------------------------------------- +! +!--------------------------------------------------------------------------- + real(kind=8) function difconf(icon,jcon) + + use clust_data + + use io_units, only: iout + use io_base, only: permut + use geometry_data, only: nres,c,cref,tabperm + use energy_data, only: nct,nnt + use control_data, only: symetr,lside,nend,nstart + use regularize_, only: fitsq + implicit none +! include 'DIMENSIONS' +! include 'sizesclu.dat' +! include 'COMMON.CONTROL' +! include 'COMMON.CLUSTER' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' + logical :: non_conv + real(kind=8) :: przes(3),obrot(3,3) + real(kind=8) :: xx(3,2*nres),yy(3,2*nres) !(3,maxres2) + integer :: i,ii,j,icon,jcon,kkk,nperm,chalen,zzz + integer :: iaperm,ibezperm,run + real(kind=8) :: rms,rmsmina +! write (iout,*) "tu dochodze" + rmsmina=10d10 + nperm=1 + do i=1,symetr + nperm=i*nperm + enddo +! write (iout,*) "nperm",nperm + call permut(symetr) +! write (iout,*) "tabperm", tabperm(1,1) + do kkk=1,nperm + if (lside) then + ii=0 + chalen=int((nend-nstart+2)/symetr) + do run=1,symetr + do i=nstart,(nstart+chalen-1) + zzz=tabperm(kkk,run) +! write (iout,*) "tutaj",zzz + ii=ii+1 + iaperm=(zzz-1)*chalen+i + ibezperm=(run-1)*chalen+i + do j=1,3 + xx(j,ii)=allcart(j,iaperm,jcon) + yy(j,ii)=cref(j,ibezperm,kkk) + enddo + enddo + enddo + do run=1,symetr + do i=nstart,(nstart+chalen-1) + zzz=tabperm(kkk,run) + ii=ii+1 + iaperm=(zzz-1)*chalen+i + ibezperm=(run-1)*chalen+i +! if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + xx(j,ii)=allcart(j,iaperm+nres,jcon) + yy(j,ii)=cref(j,ibezperm+nres,kkk) + enddo + enddo +! endif + enddo + call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) + else + chalen=int((nct-nnt+2)/symetr) + do run=1,symetr + do i=nnt,(nnt+chalen-1) + zzz=tabperm(kkk,run) +! write (iout,*) "tu szukaj", zzz,run,kkk + iaperm=(zzz-1)*chalen+i + ibezperm=(run-1)*chalen+i +! do i=nnt,nct + do j=1,3 + c(j,i)=allcart(j,iaperm,jcon) + enddo + enddo + enddo + call fitsq(rms,c(1,nstart),cref(1,nstart,kkk),nend-nstart+1,& + przes,& + obrot,non_conv) + endif + if (rms.lt.0.0) then + print *,'error, rms^2 = ',rms,icon,jcon + stop + endif + if (non_conv) print *,non_conv,icon,jcon + if (rmsmina.gt.rms) rmsmina=rms + enddo + difconf=dsqrt(rmsmina) + return + end function difconf +!------------------------------------------------------------------------------ + subroutine distout(ncon) + + use clust_data + use hc_, only:ioffset + use io_units, only: iout + implicit none +! include 'DIMENSIONS' +! include 'sizesclu.dat' + integer :: ncon + integer,parameter :: ncol=10 +! include 'COMMON.IOUNITS' +! include 'COMMON.CLUSTER' + integer :: i,j,k,jlim,jlim1,nlim,ind + real(kind=4) :: b(ncol) + + write (iout,'(a)') 'The distance matrix' + do 1 i=1,ncon,ncol + nlim=min0(i+ncol-1,ncon) + write (iout,1000) (k,k=i,nlim) + write (iout,'(8h--------,10a)') ('-------',k=i,nlim) + 1000 format (/8x,10(i4,3x)) + 1020 format (/1x,80(1h-)/) + do 2 j=i,ncon + jlim=min0(j,nlim) + if (jlim.eq.j) then + b(jlim-i+1)=0.0d0 + jlim1=jlim-1 + else + jlim1=jlim + endif + do 3 k=i,jlim1 + if (j.lt.k) then + IND=IOFFSET(NCON,j,k) + else + IND=IOFFSET(NCON,k,j) + endif + 3 b(k-i+1)=diss(IND) + write (iout,1010) j,(b(k),k=1,jlim-i+1) + 2 continue + 1 continue + 1010 format (i5,3x,10(f6.2,1x)) + return + end subroutine distout +!------------------------------------------------------------------------------ +! srtclust.f +!------------------------------------------------------------------------------ + SUBROUTINE SRTCLUST(ICUT,NCON,IB) + + use clust_data + use io_units, only: iout +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'sizesclu.dat' +! include 'COMMON.CLUSTER' +! include 'COMMON.FREE' +! include 'COMMON.IOUNITS' + implicit none + real(kind=8),dimension(:),allocatable :: prob !(maxgr) + real(kind=8) :: emin,ene,en1,sumprob + integer :: igr,i,ii,li1,li2,ligr,ico,jco,ind1,ind2 + integer :: jgr,li,nco,ib,ncon,icut +! +! Compute free energies of clusters +! + allocate(prob(maxgr)) + + do igr=1,ngr + emin=totfree(nconf(igr,1)) + totfree_gr(igr)=1.0d0 + do i=2,licz(igr) + ii=nconf(igr,i) + totfree_gr(igr)=totfree_gr(igr)+dexp(-totfree(ii)+emin) + enddo +! write (iout,*) "igr",igr," totfree",emin, +! & " totfree_gr",totfree_gr(igr) + totfree_gr(igr)=emin-dlog(totfree_gr(igr)) +! write (iout,*) igr," efree",totfree_gr(igr)/beta_h(ib) + enddo +! +! SORT CONFORMATIONS IN GROUPS ACC. TO ENERGY +! + DO 16 IGR=1,NGR + LIGR=LICZ(IGR) + DO 17 ICO=1,LIGR-1 + IND1=NCONF(IGR,ICO) + ENE=totfree(IND1) + DO 18 JCO=ICO+1,LIGR + IND2=NCONF(IGR,JCO) + EN1=totfree(IND2) + IF (EN1.LT.ENE) THEN + NCONF(IGR,ICO)=IND2 + NCONF(IGR,JCO)=IND1 + IND1=IND2 + ENE=EN1 + ENDIF + 18 CONTINUE + 17 CONTINUE + 16 CONTINUE +! +! SORT GROUPS +! + DO 71 IGR=1,NGR + ENE=totfree_gr(IGR) + DO 72 JGR=IGR+1,NGR + EN1=totfree_gr(JGR) + IF (EN1.LT.ENE) THEN + LI1=LICZ(IGR) + LI2=LICZ(JGR) + LI=MAX0(LI1,LI2) + DO 73 I=1,LI + NCO=NCONF(IGR,I) + NCONF(IGR,I)=NCONF(JGR,I) + NCONF(JGR,I)=NCO + 73 CONTINUE + totfree_gr(igr)=en1 + totfree_gr(jgr)=ene + ENE=EN1 + LICZ(IGR)=LI2 + LICZ(JGR)=LI1 + ENDIF + 72 CONTINUE + 71 CONTINUE + write (iout,'("Free energies and probabilities of clusters at",f6.1," K")')& + 1.0d0/(1.987d-3*beta_h(ib)) !' + prob(1)=1.0d0 + sumprob=1.0d0 + do i=2,ngr + prob(i)=dexp(-(totfree_gr(i)-totfree_gr(1))) + sumprob=sumprob+prob(i) + enddo + do i=1,ngr + prob(i)=prob(i)/sumprob + enddo + sumprob=0.0d0 + write (iout,'("clust efree prob sumprob")') + do i=1,ngr + sumprob=sumprob+prob(i) + write (iout,'(i5,f8.1,2f8.5)') i,totfree_gr(i)/beta_h(ib),& + prob(i),sumprob + enddo + DO 81 IGR=1,NGR + LI=LICZ(IGR) + DO 82 I=1,LI + 82 IASS(NCONF(IGR,I))=IGR + 81 CONTINUE + if (lgrp) then + do i=1,ncon + iass_tot(i,icut)=iass(i) +! write (iout,*) icut,i,iass(i),iass_tot(i,icut) + enddo + endif + RETURN + END SUBROUTINE SRTCLUST +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ diff --git a/source/cluster/cluster.f90 b/source/cluster/cluster.f90 deleted file mode 100644 index 1b6767c..0000000 --- a/source/cluster/cluster.f90 +++ /dev/null @@ -1,664 +0,0 @@ - program cluster -! -! Program to cluster united-residue MCM results. -! - use clust_data - use probability - use tracking - use hc_ - use io_clust -!#define CLUSTER - use io_units - use io_base, only: permut - use geometry_data, only: nres,theta,phi,alph,omeg,& - c,cref - use energy_data, only: nnt,nct - use control_data, only: symetr,outpdb,outmol2,titel,& - iopt,print_dist,MaxProcs - use control, only: tcpu,initialize - - use wham_data, only: punch_dist - use io_wham, only: parmread - use work_part -! include 'DIMENSIONS' -! include 'sizesclu.dat' -#ifdef MPI - use mpi_data - implicit none - include "mpif.h" - integer :: IERROR,ERRCODE !STATUS(MPI_STATUS_SIZE) -#else - implicit none -! include "COMMON.MPI" -#endif -! include 'COMMON.TIME1' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.CLUSTER' -! include 'COMMON.IOUNITS' -! include 'COMMON.FREE' - - logical,dimension(:),allocatable :: printang !(max_cut) - integer,dimension(:),allocatable :: printpdb !(max_cut) - integer,dimension(:),allocatable :: printmol2 !(max_cut) - character(len=240) lineh - REAL(kind=4),dimension(:),allocatable :: CRIT,MEMBR !(maxconf) - REAL(kind=4),dimension(:),allocatable :: CRITVAL !(maxconf-1) - INTEGER,dimension(:),allocatable :: IA,IB !(maxconf) - INTEGER,dimension(:,:),allocatable :: ICLASS !(maxconf,maxconf-1) - INTEGER,dimension(:),allocatable :: HVALS !(maxconf-1) - INTEGER,dimension(:),allocatable :: IORDER,HEIGHT !(maxconf-1) - integer,dimension(:),allocatable :: nn !(maxconf) - integer :: ndis - real(kind=4),dimension(:),allocatable :: DISNN !(maxconf) - LOGICAL,dimension(:),allocatable :: FLAG !(maxconf) - integer :: i,j,k,l,m,n,len,lev,idum,ii,ind,jj,icut,ncon,& - it,ncon_work,ind1,kkk - real(kind=8) :: t1,t2,difconf - - real(kind=8),dimension(:),allocatable :: varia !(maxvar) - real(kind=8),dimension(:),allocatable :: list_conf_ !(maxvar) - real(kind=8) :: hrtime,mintime,sectime - logical :: eof - external :: difconf -!el - real(kind=4),dimension(:),allocatable :: diss_ !(maxdist) - integer,dimension(:),allocatable :: scount_ !(maxdist) -#ifdef MPI - call MPI_Init( IERROR ) - call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR ) - call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR ) - Master = 0 - if (ierror.gt.0) then - write(iout,*) "SEVERE ERROR - Can't initialize MPI." - call mpi_finalize(ierror) - stop - endif - if (nprocs.gt.MaxProcs+1) then - write (2,*) "Error - too many processors",& - nprocs,MaxProcs+1 - write (2,*) "Increase MaxProcs and recompile" - call MPI_Finalize(IERROR) - stop - endif -#endif -!elwrite(iout,*) "before parmread" - allocate(printang(max_cut)) - allocate(printpdb(max_cut)) - allocate(printmol2(max_cut)) - call initialize -!elwrite(iout,*) "before parmread" - call openunits -!elwrite(iout,*) "before parmread" - call parmread - call read_control -!elwrite(iout,*) "after read control" - call molread -! if (refstr) call read_ref_structure(*30) - do i=1,nres - phi(i)=0.0D0 - theta(i)=0.0D0 - alph(i)=0.0D0 - omeg(i)=0.0D0 - enddo -! write (iout,*) "Before permut" -! write (iout,*) "symetr", symetr -! call flush(iout) - call permut(symetr) -! write (iout,*) "after permut" -! call flush(iout) - print *,'MAIN: nnt=',nnt,' nct=',nct - - DO I=1,NCUT - PRINTANG(I)=.FALSE. - PRINTPDB(I)=0 - printmol2(i)=0 - IF (RCUTOFF(I).LT.0.0) THEN - RCUTOFF(I)=ABS(RCUTOFF(I)) - PRINTANG(I)=.TRUE. - PRINTPDB(I)=outpdb - printmol2(i)=outmol2 - ENDIF - ENDDO - write (iout,*) 'Number of cutoffs:',NCUT - write (iout,*) 'Cutoff values:' - DO ICUT=1,NCUT - WRITE(IOUT,'(8HRCUTOFF(,I2,2H)=,F8.1,2i2)')ICUT,RCUTOFF(ICUT),& - printpdb(icut),printmol2(icut) - ENDDO - DO I=1,NRES-3 - MULT(I)=1 - ENDDO - allocate(list_conf(maxconf)) - do i=1,maxconf - list_conf(i)=i - enddo - call read_coords(ncon,*20) - - allocate(list_conf_(maxconf)) - do i=1,maxconf - list_conf_(i)=list_conf(i) - enddo - deallocate(list_conf) - allocate(list_conf(ncon)) - do i=1,ncon - list_conf(i)=list_conf_(i) - enddo - deallocate(list_conf_) - -!el call alloc_clust_arrays(ncon) - - write (iout,*) 'from read_coords: ncon',ncon - - write (iout,*) "nT",nT - do iT=1,nT - write (iout,*) "iT",iT -#ifdef MPI - call work_partition(.true.,ncon) -#endif -!elwrite(iout,*)"after work partition, ncon_work=", ncon_work,ncon - - call probabl(iT,ncon_work,ncon,*20) - -!elwrite(iout,*)"after probabl, ncon_work=", ncon_work,ncon - - if (ncon_work.lt.2) then - write (iout,*) "Too few conformations; clustering skipped" - exit - endif -#ifdef MPI - ndis=ncon_work*(ncon_work-1)/2 - call work_partition(.true.,ndis) -#endif -!el call alloc_clust_arrays(ncon_work) - allocate(ICC(ncon_work)) - allocate(DISS(maxdist)) - - DO I=1,NCON_work - ICC(I)=I - ENDDO - WRITE (iout,'(A80)') TITEL - t1=tcpu() -! -! CALCULATE DISTANCES -! - call daread_ccoords(1,ncon_work) - ind1=0 - DO I=1,NCON_work-1 - if (mod(i,100).eq.0) print *,'Calculating RMS i=',i - do k=1,2*nres - do l=1,3 - c(l,k)=allcart(l,k,i) - enddo - enddo - kkk=1 - do k=1,nres - do l=1,3 - cref(l,k,kkk)=c(l,k) - enddo - enddo - DO J=I+1,NCON_work - IND=IOFFSET(NCON_work,I,J) -#ifdef MPI - if (ind.ge.indstart(me) .and. ind.le.indend(me)) then -#endif - ind1=ind1+1 - DISS(IND1)=DIFCONF(I,J) -! write (iout,'(2i4,i10,f10.5)') i,j,ind,DISS(IND) -#ifdef MPI - endif -#endif - ENDDO - ENDDO - t2=tcpu() - WRITE (iout,'(/a,1pe14.5,a/)') & - 'Time for distance calculation:',T2-T1,' sec.' - t1=tcpu() - PRINT '(a)','End of distance computation' -!el--------------- - allocate(diss_(maxdist)) - allocate(scount_(0:nprocs)) - - do i=1,maxdist - diss_(i)=diss(i) - enddo - do i=0,nprocs - scount_(i)=scount(i) - enddo -!el----------- -#ifdef MPI - call MPI_Gatherv(diss_(1),scount_(me),MPI_REAL,diss(1),& - scount(0),idispl(0),MPI_REAL,Master,MPI_COMM_WORLD, IERROR) - if (me.eq.master) then -#endif - deallocate(diss_) - deallocate(scount_) - - open(80,file='/tmp/distance',form='unformatted') - do i=1,ndis - write(80) diss(i) - enddo - if (punch_dist) then - do i=1,ncon_work-1 - do j=i+1,ncon_work - IND=IOFFSET(NCON,I,J) - write (jrms,'(2i5,2f10.5)') i,j,diss(IND),& - energy(j)-energy(i) - enddo - enddo - endif -! -! Print out the RMS deviation matrix. -! - if (print_dist) CALL DISTOUT(NCON_work) -! -! call hierarchical clustering HC from F. Murtagh -! - N=NCON_work - LEN = (N*(N-1))/2 - write(iout,*) "-------------------------------------------" - write(iout,*) "HIERARCHICAL CLUSTERING using" - if (iopt.eq.1) then - write(iout,*) "WARD'S MINIMUM VARIANCE METHOD" - elseif (iopt.eq.2) then - write(iout,*) "SINGLE LINK METHOD" - elseif (iopt.eq.3) then - write(iout,*) "COMPLETE LINK METHOD" - elseif (iopt.eq.4) then - write(iout,*) "AVERAGE LINK (OR GROUP AVERAGE) METHOD" - elseif (iopt.eq.5) then - write(iout,*) "MCQUITTY'S METHOD" - elseif (iopt.eq.6) then - write(iout,*) "MEDIAN (GOWER'S) METHOD" - elseif (iopt.eq.7) then - write(iout,*) "CENTROID METHOD" - else - write(iout,*) "IOPT=",iopt," IS INVALID, use 1-7" - write(*,*) "IOPT=",iopt," IS INVALID, use 1-7" - stop - endif - write(iout,*) - write(iout,*) "hc.f by F. Murtagh, ESA/ESO/STECF, Garching" - write(iout,*) "February 1986" - write(iout,*) "References:" - write(iout,*) "1. Multidimensional clustering algorithms" - write(iout,*) " Fionn Murtagh" - write(iout,*) " Vienna : Physica-Verlag, 1985." - write(iout,*) "2. Multivariate data analysis" - write(iout,*) " Fionn Murtagh and Andre Heck" - write(iout,*) " Kluwer Academic Publishers, 1987" - write(iout,*) "-------------------------------------------" - write(iout,*) - -#ifdef DEBUG - write (iout,*) "The TOTFREE array" - do i=1,ncon_work - write (iout,'(2i5,f10.5)') i,list_conf(i),totfree(i) - enddo -#endif - allocate(CRIT(N),MEMBR(N)) !(maxconf) - allocate(CRITVAL(N-1)) !(maxconf-1) - allocate(IA(N),IB(N)) - allocate(ICLASS(N,N-1)) !(maxconf,maxconf-1) - allocate(HVALS(N-1)) !(maxconf-1) - allocate(IORDER(N-1),HEIGHT(N-1)) !(maxconf-1) - allocate(nn(N)) !(maxconf) - allocate(DISNN(N)) !(maxconf) - allocate(FLAG(N)) !(maxconf) - - call flush(iout) - CALL HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,DISS) - LEV = N-1 - write (iout,*) "n",n," ncon_work",ncon_work," lev",lev - if (lev.lt.2) then - write (iout,*) "Too few conformations to cluster." - goto 192 - endif - CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT) -! CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL) - - allocate(licz(maxgr)) - allocate(iass(maxgr)) - allocate(nconf(maxgr,maxingr)) - allocate(totfree_gr(maxgr)) - - do i=1,maxgr - licz(i)=0 - enddo - icut=1 - i=1 - NGR=i+1 - do j=1,n - licz(iclass(j,i))=licz(iclass(j,i))+1 - nconf(iclass(j,i),licz(iclass(j,i)))=j -! write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)), -! & nconf(iclass(j,i),licz(iclass(j,i))) - enddo - do i=1,lev-1 - - idum=lev-i - DO L=1,LEV - IF (HEIGHT(L).EQ.IDUM) GOTO 190 - ENDDO - 190 IDUM=L - write(IOUT,*) "i+1",i+1," idum",idum," critval",CRITVAL(IDUM),& - " icut",icut," cutoff",rcutoff(icut) - IF (CRITVAL(IDUM).LT. RCUTOFF(ICUT)) THEN - WRITE (iout,'(/a,f10.5)') 'AT CUTOFF:',rcutoff(icut) - write (iout,'(a,f8.2)') 'Maximum distance found:',& - CRITVAL(IDUM) - CALL SRTCLUST(ICUT,ncon_work,iT) - CALL TRACK(ICUT) - CALL WRTCLUST(ncon_work,ICUT,PRINTANG,PRINTPDB,PRINTMOL2,iT) - icut=icut+1 - if (icut.gt.ncut) goto 191 - ENDIF - NGR=i+1 - do l=1,maxgr - licz(l)=0 - enddo - do j=1,n - enddo - do j=1,n - licz(iclass(j,i))=licz(iclass(j,i))+1 - nconf(iclass(j,i),licz(iclass(j,i)))=j -!d write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)),& -!d nconf(iclass(j,i),licz(iclass(j,i))) -!d print *,j,iclass(j,i), -!d & licz(iclass(j,i)),nconf(iclass(j,i),licz(iclass(j,i))) - enddo - enddo - 191 continue -! - if (plot_tree) then - CALL WRITRACK - CALL PLOTREE - endif -! - t2=tcpu() - WRITE (iout,'(/a,1pe14.5,a/)') & - 'Total time for clustering:',T2-T1,' sec.' -#ifdef MPI - endif -#endif - 192 continue - enddo -! - close(icbase,status="delete") -#ifdef MPI -!el call MPI_Finalize(MPI_COMM_WORLD,IERROR) - call MPI_Finalize(IERROR) -#endif - stop '********** Program terminated normally.' - 20 write (iout,*) "Error reading coordinates" -#ifdef MPI -!el call MPI_Finalize(MPI_COMM_WORLD,IERROR) - call MPI_Finalize(IERROR) -#endif - stop - 30 write (iout,*) "Error reading reference structure" -#ifdef MPI -!el call MPI_Finalize(MPI_COMM_WORLD,IERROR) - call MPI_Finalize(IERROR) -#endif - stop - end program cluster -!--------------------------------------------------------------------------- -! -!--------------------------------------------------------------------------- - real(kind=8) function difconf(icon,jcon) - - use clust_data - - use io_units, only: iout - use io_base, only: permut - use geometry_data, only: nres,c,cref,tabperm - use energy_data, only: nct,nnt - use control_data, only: symetr,lside,nend,nstart - use regularize_, only: fitsq - implicit none -! include 'DIMENSIONS' -! include 'sizesclu.dat' -! include 'COMMON.CONTROL' -! include 'COMMON.CLUSTER' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' - logical :: non_conv - real(kind=8) :: przes(3),obrot(3,3) - real(kind=8) :: xx(3,2*nres),yy(3,2*nres) !(3,maxres2) - integer :: i,ii,j,icon,jcon,kkk,nperm,chalen,zzz - integer :: iaperm,ibezperm,run - real(kind=8) :: rms,rmsmina -! write (iout,*) "tu dochodze" - rmsmina=10d10 - nperm=1 - do i=1,symetr - nperm=i*nperm - enddo -! write (iout,*) "nperm",nperm - call permut(symetr) -! write (iout,*) "tabperm", tabperm(1,1) - do kkk=1,nperm - if (lside) then - ii=0 - chalen=int((nend-nstart+2)/symetr) - do run=1,symetr - do i=nstart,(nstart+chalen-1) - zzz=tabperm(kkk,run) -! write (iout,*) "tutaj",zzz - ii=ii+1 - iaperm=(zzz-1)*chalen+i - ibezperm=(run-1)*chalen+i - do j=1,3 - xx(j,ii)=allcart(j,iaperm,jcon) - yy(j,ii)=cref(j,ibezperm,kkk) - enddo - enddo - enddo - do run=1,symetr - do i=nstart,(nstart+chalen-1) - zzz=tabperm(kkk,run) - ii=ii+1 - iaperm=(zzz-1)*chalen+i - ibezperm=(run-1)*chalen+i -! if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - xx(j,ii)=allcart(j,iaperm+nres,jcon) - yy(j,ii)=cref(j,ibezperm+nres,kkk) - enddo - enddo -! endif - enddo - call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) - else - chalen=int((nct-nnt+2)/symetr) - do run=1,symetr - do i=nnt,(nnt+chalen-1) - zzz=tabperm(kkk,run) -! write (iout,*) "tu szukaj", zzz,run,kkk - iaperm=(zzz-1)*chalen+i - ibezperm=(run-1)*chalen+i -! do i=nnt,nct - do j=1,3 - c(j,i)=allcart(j,iaperm,jcon) - enddo - enddo - enddo - call fitsq(rms,c(1,nstart),cref(1,nstart,kkk),nend-nstart+1,& - przes,& - obrot,non_conv) - endif - if (rms.lt.0.0) then - print *,'error, rms^2 = ',rms,icon,jcon - stop - endif - if (non_conv) print *,non_conv,icon,jcon - if (rmsmina.gt.rms) rmsmina=rms - enddo - difconf=dsqrt(rmsmina) - return - end function difconf -!------------------------------------------------------------------------------ - subroutine distout(ncon) - - use clust_data - use hc_, only:ioffset - use io_units, only: iout - implicit none -! include 'DIMENSIONS' -! include 'sizesclu.dat' - integer :: ncon - integer,parameter :: ncol=10 -! include 'COMMON.IOUNITS' -! include 'COMMON.CLUSTER' - integer :: i,j,k,jlim,jlim1,nlim,ind - real(kind=4) :: b(ncol) - - write (iout,'(a)') 'The distance matrix' - do 1 i=1,ncon,ncol - nlim=min0(i+ncol-1,ncon) - write (iout,1000) (k,k=i,nlim) - write (iout,'(8h--------,10a)') ('-------',k=i,nlim) - 1000 format (/8x,10(i4,3x)) - 1020 format (/1x,80(1h-)/) - do 2 j=i,ncon - jlim=min0(j,nlim) - if (jlim.eq.j) then - b(jlim-i+1)=0.0d0 - jlim1=jlim-1 - else - jlim1=jlim - endif - do 3 k=i,jlim1 - if (j.lt.k) then - IND=IOFFSET(NCON,j,k) - else - IND=IOFFSET(NCON,k,j) - endif - 3 b(k-i+1)=diss(IND) - write (iout,1010) j,(b(k),k=1,jlim-i+1) - 2 continue - 1 continue - 1010 format (i5,3x,10(f6.2,1x)) - return - end subroutine distout -!------------------------------------------------------------------------------ -! srtclust.f -!------------------------------------------------------------------------------ - SUBROUTINE SRTCLUST(ICUT,NCON,IB) - - use clust_data - use io_units, only: iout -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'sizesclu.dat' -! include 'COMMON.CLUSTER' -! include 'COMMON.FREE' -! include 'COMMON.IOUNITS' - implicit none - real(kind=8),dimension(:),allocatable :: prob !(maxgr) - real(kind=8) :: emin,ene,en1,sumprob - integer :: igr,i,ii,li1,li2,ligr,ico,jco,ind1,ind2 - integer :: jgr,li,nco,ib,ncon,icut -! -! Compute free energies of clusters -! - allocate(prob(maxgr)) - - do igr=1,ngr - emin=totfree(nconf(igr,1)) - totfree_gr(igr)=1.0d0 - do i=2,licz(igr) - ii=nconf(igr,i) - totfree_gr(igr)=totfree_gr(igr)+dexp(-totfree(ii)+emin) - enddo -! write (iout,*) "igr",igr," totfree",emin, -! & " totfree_gr",totfree_gr(igr) - totfree_gr(igr)=emin-dlog(totfree_gr(igr)) -! write (iout,*) igr," efree",totfree_gr(igr)/beta_h(ib) - enddo -! -! SORT CONFORMATIONS IN GROUPS ACC. TO ENERGY -! - DO 16 IGR=1,NGR - LIGR=LICZ(IGR) - DO 17 ICO=1,LIGR-1 - IND1=NCONF(IGR,ICO) - ENE=totfree(IND1) - DO 18 JCO=ICO+1,LIGR - IND2=NCONF(IGR,JCO) - EN1=totfree(IND2) - IF (EN1.LT.ENE) THEN - NCONF(IGR,ICO)=IND2 - NCONF(IGR,JCO)=IND1 - IND1=IND2 - ENE=EN1 - ENDIF - 18 CONTINUE - 17 CONTINUE - 16 CONTINUE -! -! SORT GROUPS -! - DO 71 IGR=1,NGR - ENE=totfree_gr(IGR) - DO 72 JGR=IGR+1,NGR - EN1=totfree_gr(JGR) - IF (EN1.LT.ENE) THEN - LI1=LICZ(IGR) - LI2=LICZ(JGR) - LI=MAX0(LI1,LI2) - DO 73 I=1,LI - NCO=NCONF(IGR,I) - NCONF(IGR,I)=NCONF(JGR,I) - NCONF(JGR,I)=NCO - 73 CONTINUE - totfree_gr(igr)=en1 - totfree_gr(jgr)=ene - ENE=EN1 - LICZ(IGR)=LI2 - LICZ(JGR)=LI1 - ENDIF - 72 CONTINUE - 71 CONTINUE - write (iout,'("Free energies and probabilities of clusters at",f6.1," K")')& - 1.0d0/(1.987d-3*beta_h(ib)) !' - prob(1)=1.0d0 - sumprob=1.0d0 - do i=2,ngr - prob(i)=dexp(-(totfree_gr(i)-totfree_gr(1))) - sumprob=sumprob+prob(i) - enddo - do i=1,ngr - prob(i)=prob(i)/sumprob - enddo - sumprob=0.0d0 - write (iout,'("clust efree prob sumprob")') - do i=1,ngr - sumprob=sumprob+prob(i) - write (iout,'(i5,f8.1,2f8.5)') i,totfree_gr(i)/beta_h(ib),& - prob(i),sumprob - enddo - DO 81 IGR=1,NGR - LI=LICZ(IGR) - DO 82 I=1,LI - 82 IASS(NCONF(IGR,I))=IGR - 81 CONTINUE - if (lgrp) then - do i=1,ncon - iass_tot(i,icut)=iass(i) -! write (iout,*) icut,i,iass(i),iass_tot(i,icut) - enddo - endif - RETURN - END SUBROUTINE SRTCLUST -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ diff --git a/source/cluster/hc.F90 b/source/cluster/hc.F90 new file mode 100644 index 0000000..113e71c --- /dev/null +++ b/source/cluster/hc.F90 @@ -0,0 +1,511 @@ +!*********************** Contents **************************************** +!* Sample driver program, VAX-11 Fortran; ********************************** +!* HC: O(n^2) time, O(n^2) space hierarchical clustering, Fortran 77 ******* +!* HCASS: determine cluster-memberships, Fortran 77. *********************** +!* HCDEN: draw upper part of dendrogram, VAX-11 Fortran. ******************* +!* Sample data set: last 36 lines. ***************************************** +!*************************************************************************** +! REAL DATA(18,16),CRIT(18),MEMBR(18) +! REAL CRITVAL(9) +! INTEGER IA(18),IB(18) +! INTEGER ICLASS(18,9),HVALS(9) +! INTEGER IORDER(9),HEIGHT(9) +! DIMENSION NN(18),DISNN(18) +! REAL D(153) +! LOGICAL FLAG(18) +! IN ABOVE, 18=N, 16=M, 9=LEV, 153=N(N-1)/2. +! +! +! OPEN(UNIT=21,STATUS='OLD',FILE='SPECTR.DAT') +! +! +! N = 18 +! M = 16 +! DO I=1,N +! READ(21,100)(DATA(I,J),J=1,M) +! ENDDO +! 100 FORMAT(8F7.1) +! +! +! LEN = (N*(N-1))/2 +! IOPT=1 +! CALL HC(N,M,LEN,IOPT,DATA,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,D) +! +! +! LEV = 9 +! CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT) +! +! +! CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL) +! +! +! END +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C +! C +! HIERARCHICAL CLUSTERING using (user-specified) criterion. C +! C +! Parameters: C +! C +!removed DATA(N,M) input data matrix, C +! DISS(LEN) dissimilarities in lower half diagonal C +! storage; LEN = N.N-1/2, C +! IOPT clustering criterion to be used, C +! IA, IB, CRIT history of agglomerations; dimensions C +! N, first N-1 locations only used, C +! MEMBR, NN, DISNN vectors of length N, used to store C +! cluster cardinalities, current nearest C +! neighbour, and the dissimilarity assoc. C +! with the latter. C +! FLAG boolean indicator of agglomerable obj./ C +! clusters. C +! C +! F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C +! C +!------------------------------------------------------------C + module hc_ +!----------------------------------------------------------------------------- + use io_units + use names + use clust_data + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! hc.f +!----------------------------------------------------------------------------- + + SUBROUTINE HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,& + FLAG,DISS) + integer :: N,M,LEN,IOPT + REAL(kind=4) :: MEMBR(N) + REAL(kind=4) :: DISS(LEN) + INTEGER :: IA(N),IB(N) + REAL(kind=4) :: CRIT(N) + integer,DIMENSION(N) :: NN + real(kind=4),dimension(N) ::DISNN + LOGICAL :: FLAG(N) + REAL(kind=4) INF + DATA INF /1.E+20/ + integer :: I,J,NCL,IND,IM,JM,I2,J2,K,IND1,IND2,IND3,JJ + real(kind=8) :: DMIN,X,XX +! +! Initializations +! + DO I=1,N + MEMBR(I)=1. + FLAG(I)=.TRUE. + ENDDO + NCL=N +! +! Construct dissimilarity matrix +! + DO I=1,N-1 + DO J=I+1,N + IND=IOFFSET(N,I,J) +!input DISS(IND)=0. +!input DO K=1,M +!input DISS(IND)=DISS(IND)+(DATA(I,K)-DATA(J,K))**2 +!input ENDDO + IF (IOPT.EQ.1) DISS(IND)=DISS(IND)/2. +! (Above is done for the case of the min. var. method +! where merging criteria are defined in terms of variances +! rather than distances.) + ENDDO + ENDDO +! +! Carry out an agglomeration - first create list of NNs +! + DO I=1,N-1 + DMIN=INF + DO J=I+1,N + IND=IOFFSET(N,I,J) + IF (DISS(IND).GE.DMIN) GOTO 500 + DMIN=DISS(IND) + JM=J + 500 CONTINUE + ENDDO + NN(I)=JM + DISNN(I)=DMIN + ENDDO +! + 400 CONTINUE +! Next, determine least diss. using list of NNs + DMIN=INF + DO I=1,N-1 + IF (.NOT.FLAG(I)) GOTO 600 + IF (DISNN(I).GE.DMIN) GOTO 600 + DMIN=DISNN(I) + IM=I + JM=NN(I) + 600 CONTINUE + ENDDO + NCL=NCL-1 +! +! This allows an agglomeration to be carried out. +! + I2=MIN0(IM,JM) + J2=MAX0(IM,JM) + IA(N-NCL)=I2 + IB(N-NCL)=J2 + CRIT(N-NCL)=DMIN +! +! Update dissimilarities from new cluster. +! + FLAG(J2)=.FALSE. + DMIN=INF + DO K=1,N + IF (.NOT.FLAG(K)) GOTO 800 + IF (K.EQ.I2) GOTO 800 + X=MEMBR(I2)+MEMBR(J2)+MEMBR(K) + IF (I2.LT.K) THEN + IND1=IOFFSET(N,I2,K) + ELSE + IND1=IOFFSET(N,K,I2) + ENDIF + IF (J2.LT.K) THEN + IND2=IOFFSET(N,J2,K) + ELSE + IND2=IOFFSET(N,K,J2) + ENDIF + IND3=IOFFSET(N,I2,J2) + XX=DISS(IND3) +! +! WARD'S MINIMUM VARIANCE METHOD - IOPT=1. +! + IF (IOPT.EQ.1) THEN + DISS(IND1)=(MEMBR(I2)+MEMBR(K))*DISS(IND1)+ & + (MEMBR(J2)+MEMBR(K))*DISS(IND2)- & + MEMBR(K)*XX + DISS(IND1)=DISS(IND1)/X + ENDIF +! +! SINGLE LINK METHOD - IOPT=2. +! + IF (IOPT.EQ.2) THEN + DISS(IND1)=MIN(DISS(IND1),DISS(IND2)) + ENDIF +! +! COMPLETE LINK METHOD - IOPT=3. +! + IF (IOPT.EQ.3) THEN + DISS(IND1)=MAX(DISS(IND1),DISS(IND2)) + ENDIF +! +! AVERAGE LINK (OR GROUP AVERAGE) METHOD - IOPT=4. +! + IF (IOPT.EQ.4) THEN + DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2))/ & + (MEMBR(I2)+MEMBR(J2)) + ENDIF +! +! MCQUITTY'S METHOD - IOPT=5. +! + IF (IOPT.EQ.5) THEN + DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2) + ENDIF +! +! MEDIAN (GOWER'S) METHOD - IOPT=6. +! + IF (IOPT.EQ.6) THEN + DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2)-0.25*XX + ENDIF +! +! CENTROID METHOD - IOPT=7. +! + IF (IOPT.EQ.7) THEN + DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2)- & + MEMBR(I2)*MEMBR(J2)*XX/(MEMBR(I2)+MEMBR(J2)))/ & + (MEMBR(I2)+MEMBR(J2)) + ENDIF +! + IF (I2.GT.K) GOTO 800 + IF (DISS(IND1).GE.DMIN) GOTO 800 + DMIN=DISS(IND1) + JJ=K + 800 CONTINUE + ENDDO + MEMBR(I2)=MEMBR(I2)+MEMBR(J2) + DISNN(I2)=DMIN + NN(I2)=JJ +! +! Update list of NNs insofar as this is required. +! + DO I=1,N-1 + IF (.NOT.FLAG(I)) GOTO 900 + IF (NN(I).EQ.I2) GOTO 850 + IF (NN(I).EQ.J2) GOTO 850 + GOTO 900 + 850 CONTINUE +! (Redetermine NN of I:) + DMIN=INF + DO J=I+1,N + IND=IOFFSET(N,I,J) + IF (.NOT.FLAG(J)) GOTO 870 + IF (I.EQ.J) GOTO 870 + IF (DISS(IND).GE.DMIN) GOTO 870 + DMIN=DISS(IND) + JJ=J + 870 CONTINUE + ENDDO + NN(I)=JJ + DISNN(I)=DMIN + 900 CONTINUE + ENDDO +! +! Repeat previous steps until N-1 agglomerations carried out. +! + IF (NCL.GT.1) GOTO 400 +! +! + RETURN + END SUBROUTINE HC +!----------------------------------------------------------------------------- +! +! + integer FUNCTION IOFFSET(N,I,J) +! Map row I and column J of upper half diagonal symmetric matrix +! onto vector. + integer :: N,I,J + IOFFSET=J+(I-1)*N-(I*(I+1))/2 + RETURN + END FUNCTION IOFFSET +!----------------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C +! C +! Given a HIERARCHIC CLUSTERING, described as a sequence of C +! agglomerations, derive the assignments into clusters for the C +! top LEV-1 levels of the hierarchy. C +! Prepare also the required data for representing the C +! dendrogram of this top part of the hierarchy. C +! C +! Parameters: C +! C +! IA, IB, CRIT: vectors of dimension N defining the agglomer- C +! ations. C +! LEV: number of clusters in largest partition. C +! HVALS: vector of dim. LEV, used internally only. C +! ICLASS: array of cluster assignments; dim. N by LEV. C +! IORDER, CRITVAL, HEIGHT: vectors describing the dendrogram, C +! all of dim. LEV. C +! C +! F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C +! C +! HISTORY C +! C +! Bounds bug fix, Oct. 1990, F. Murtagh. C +! Inserted line "IF (LOC.GT.LEV) GOTO 58" on line 48. This was C +! occassioned by incorrect termination of this loop when I C +! reached its (lower) extremity, i.e. N-LEV. Without the C +! /CHECK=(BOUNDS) option on VAX/VMS compilation, this inserted C +! statement was not necessary. C +!---------------------------------------------------------------C + SUBROUTINE HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,& + CRITVAL,HEIGHT) +! include 'sizesclu.dat' +! include 'COMMON.IOUNITS' + integer :: N,LEV +!el integer :: ICLASS(maxconf,maxconf-1) + integer :: ICLASS(N,N-1) + INTEGER :: IA(N),IB(N),HVALS(LEV),IORDER(LEV),& + HEIGHT(LEV) + REAL(kind=4) :: CRIT(N),CRITVAL(LEV) + integer :: I,J,LOC,LEVEL,ICL,ILEV,NCL,K +! +! Pick out the clusters which the N objects belong to, +! at levels N-2, N-3, ... N-LEV+1 of the hierarchy. +! The clusters are identified by the lowest seq. no. of +! their members. +! There are 2, 3, ... LEV clusters, respectively, for the +! above levels of the hierarchy. +! + HVALS(1)=1 + HVALS(2)=IB(N-1) + LOC=3 + DO 59 I=N-2,N-LEV,-1 + DO 52 J=1,LOC-1 + IF (IA(I).EQ.HVALS(J)) GOTO 54 + 52 CONTINUE + HVALS(LOC)=IA(I) + LOC=LOC+1 + 54 CONTINUE + DO 56 J=1,LOC-1 + IF (IB(I).EQ.HVALS(J)) GOTO 58 + 56 CONTINUE + IF (LOC.GT.LEV) GOTO 58 + HVALS(LOC)=IB(I) + LOC=LOC+1 + 58 CONTINUE + 59 CONTINUE +! + DO 400 LEVEL=N-LEV,N-2 + DO 200 I=1,N + ICL=I + DO 100 ILEV=1,LEVEL + 100 IF (IB(ILEV).EQ.ICL) ICL=IA(ILEV) + NCL=N-LEVEL + ICLASS(I,NCL-1)=ICL + 200 CONTINUE + 400 CONTINUE +! + DO 120 I=1,N + DO 120 J=1,LEV-1 + DO 110 K=2,LEV + IF (ICLASS(I,J).NE.HVALS(K)) GOTO 110 + ICLASS(I,J)=K + GOTO 120 + 110 CONTINUE + 120 CONTINUE +! + WRITE (iout,450) (j,j=2,LEV) + 450 FORMAT(4X,' SEQ NOS',8(i2,'CL'),10000(i3,'CL')) + WRITE (iout,470) (' ---',j=2,LEV) + 470 FORMAT(4X,' -------',10000a4) + DO 500 I=1,N + WRITE (iout,600) I,(ICLASS(I,J),J=1,LEV-1) + 600 FORMAT(I11,8I4,10000i5) + 500 CONTINUE +! +! Determine an ordering of the LEV clusters (at level LEV-1) +! for later representation of the dendrogram. +! These are stored in IORDER. +! Determine the associated ordering of the criterion values +! for the vertical lines in the dendrogram. +! The ordinal values of these criterion values may be used in +! preference, and these are stored in HEIGHT. +! Finally, note that the LEV clusters are renamed so that they +! have seq. nos. 1 to LEV. +! + IORDER(1)=IA(N-1) + IORDER(2)=IB(N-1) + CRITVAL(1)=0.0 + CRITVAL(2)=CRIT(N-1) + HEIGHT(1)=LEV + HEIGHT(2)=LEV-1 + LOC=2 + DO 700 I=N-2,N-LEV+1,-1 + DO 650 J=1,LOC + IF (IA(I).EQ.IORDER(J)) THEN +! Shift rightwards and insert IB(I) beside IORDER(J): + DO 630 K=LOC+1,J+1,-1 + IORDER(K)=IORDER(K-1) + CRITVAL(K)=CRITVAL(K-1) + HEIGHT(K)=HEIGHT(K-1) + 630 CONTINUE + IORDER(J+1)=IB(I) + CRITVAL(J+1)=CRIT(I) + HEIGHT(J+1)=I-(N-LEV) + LOC=LOC+1 + ENDIF + 650 CONTINUE + 700 CONTINUE + DO 705 I=1,LEV + DO 703 J=1,LEV + IF (HVALS(I).EQ.IORDER(J)) THEN + IORDER(J)=I + GOTO 705 + ENDIF + 703 CONTINUE + 705 CONTINUE +! + RETURN + END SUBROUTINE HCASS +!----------------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++C +! C +! Construct a DENDROGRAM of the top 8 levels of C +! a HIERARCHIC CLUSTERING. C +! C +! Parameters: C +! C +! IORDER, HEIGHT, CRITVAL: vectors of length LEV C +! defining the dendrogram. C +! These are: the ordering of objects C +! along the bottom of the dendrogram C +! (IORDER); the height of the vertical C +! above each object, in ordinal values C +! (HEIGHT); and in real values (CRITVAL).C +! C +! NOTE: these vectors MUST have been set up with C +! LEV = 9 in the prior call to routine C +! HCASS. +! C +! F. Murtagh, ESA/ESO/STECF, Garching, Feb. 1986.C +! C +!-------------------------------------------------C + SUBROUTINE HCDEN(LEV,IORDER,HEIGHT,CRITVAL) +! include 'COMMON.IOUNITS' + integer :: LEV + CHARACTER(len=80) :: LINE + INTEGER :: IORDER(LEV),HEIGHT(LEV) + REAL(kind=4) :: CRITVAL(LEV) +! INTEGER OUT(3*LEV,3*LEV) +! INTEGER UP,ACROSS,BLANK + CHARACTER(len=1) :: OUT(3*LEV,3*LEV) + CHARACTER(len=1) :: UP,ACROSS,BLANK + DATA UP,ACROSS,BLANK /'|','-',' '/ + integer :: I,I2,J,J2,K,I3,L,IC,IDUM +! +! + DO I=1,3*LEV + DO J=1,3*LEV + OUT(I,J)=BLANK + ENDDO + ENDDO +! +! + DO I=3,3*LEV,3 + I2=I/3 +! + J2=3*LEV+1-3*HEIGHT(I2) + DO J=3*LEV,J2,-1 + OUT(J,I)=UP + ENDDO +! + DO K=I,3,-1 + I3=INT((K+2)/3) + IF ( (3*LEV+1-HEIGHT(I3)*3).LT.J2) GOTO 100 + OUT(J2,K)=ACROSS + ENDDO + 100 CONTINUE +! + ENDDO +! +! + IC=3 + DO I=1,3*LEV + IF (I.EQ.IC+1) THEN + IDUM=IC/3 + IDUM=LEV-IDUM + DO L=1,LEV + IF (HEIGHT(L).EQ.IDUM) GOTO 190 + ENDDO + 190 IDUM=L + WRITE(iout,200) CRITVAL(IDUM),(OUT(I,J),J=1,3*LEV) + IC=IC+3 + ELSE + LINE = ' ' + WRITE(iout,210) (OUT(I,J),J=1,3*LEV) + ENDIF + 200 FORMAT(1H ,8X,F12.2,4X,27000A1) + 210 FORMAT(1H ,24X,27000A1) + ENDDO + WRITE(iout,250) + WRITE(iout,220)(IORDER(J),J=1,LEV) + WRITE(iout,250) + 220 FORMAT(1H ,24X,9000I3) + WRITE(iout,230) LEV + 230 FORMAT(1H ,13X,'CRITERION CLUSTERS 1 TO ',i3) + WRITE(iout,240) LEV-1 + 240 FORMAT(1H ,13X,'VALUES. (TOP ',i3,' LEVELS OF HIERARCHY).') + 250 FORMAT(/) +! +! + RETURN + END SUBROUTINE HCDEN +!----------------------------------------------------------------------------- + end module hc_ +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- diff --git a/source/cluster/hc.f90 b/source/cluster/hc.f90 deleted file mode 100644 index 113e71c..0000000 --- a/source/cluster/hc.f90 +++ /dev/null @@ -1,511 +0,0 @@ -!*********************** Contents **************************************** -!* Sample driver program, VAX-11 Fortran; ********************************** -!* HC: O(n^2) time, O(n^2) space hierarchical clustering, Fortran 77 ******* -!* HCASS: determine cluster-memberships, Fortran 77. *********************** -!* HCDEN: draw upper part of dendrogram, VAX-11 Fortran. ******************* -!* Sample data set: last 36 lines. ***************************************** -!*************************************************************************** -! REAL DATA(18,16),CRIT(18),MEMBR(18) -! REAL CRITVAL(9) -! INTEGER IA(18),IB(18) -! INTEGER ICLASS(18,9),HVALS(9) -! INTEGER IORDER(9),HEIGHT(9) -! DIMENSION NN(18),DISNN(18) -! REAL D(153) -! LOGICAL FLAG(18) -! IN ABOVE, 18=N, 16=M, 9=LEV, 153=N(N-1)/2. -! -! -! OPEN(UNIT=21,STATUS='OLD',FILE='SPECTR.DAT') -! -! -! N = 18 -! M = 16 -! DO I=1,N -! READ(21,100)(DATA(I,J),J=1,M) -! ENDDO -! 100 FORMAT(8F7.1) -! -! -! LEN = (N*(N-1))/2 -! IOPT=1 -! CALL HC(N,M,LEN,IOPT,DATA,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,D) -! -! -! LEV = 9 -! CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT) -! -! -! CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL) -! -! -! END -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C -! C -! HIERARCHICAL CLUSTERING using (user-specified) criterion. C -! C -! Parameters: C -! C -!removed DATA(N,M) input data matrix, C -! DISS(LEN) dissimilarities in lower half diagonal C -! storage; LEN = N.N-1/2, C -! IOPT clustering criterion to be used, C -! IA, IB, CRIT history of agglomerations; dimensions C -! N, first N-1 locations only used, C -! MEMBR, NN, DISNN vectors of length N, used to store C -! cluster cardinalities, current nearest C -! neighbour, and the dissimilarity assoc. C -! with the latter. C -! FLAG boolean indicator of agglomerable obj./ C -! clusters. C -! C -! F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C -! C -!------------------------------------------------------------C - module hc_ -!----------------------------------------------------------------------------- - use io_units - use names - use clust_data - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! hc.f -!----------------------------------------------------------------------------- - - SUBROUTINE HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,& - FLAG,DISS) - integer :: N,M,LEN,IOPT - REAL(kind=4) :: MEMBR(N) - REAL(kind=4) :: DISS(LEN) - INTEGER :: IA(N),IB(N) - REAL(kind=4) :: CRIT(N) - integer,DIMENSION(N) :: NN - real(kind=4),dimension(N) ::DISNN - LOGICAL :: FLAG(N) - REAL(kind=4) INF - DATA INF /1.E+20/ - integer :: I,J,NCL,IND,IM,JM,I2,J2,K,IND1,IND2,IND3,JJ - real(kind=8) :: DMIN,X,XX -! -! Initializations -! - DO I=1,N - MEMBR(I)=1. - FLAG(I)=.TRUE. - ENDDO - NCL=N -! -! Construct dissimilarity matrix -! - DO I=1,N-1 - DO J=I+1,N - IND=IOFFSET(N,I,J) -!input DISS(IND)=0. -!input DO K=1,M -!input DISS(IND)=DISS(IND)+(DATA(I,K)-DATA(J,K))**2 -!input ENDDO - IF (IOPT.EQ.1) DISS(IND)=DISS(IND)/2. -! (Above is done for the case of the min. var. method -! where merging criteria are defined in terms of variances -! rather than distances.) - ENDDO - ENDDO -! -! Carry out an agglomeration - first create list of NNs -! - DO I=1,N-1 - DMIN=INF - DO J=I+1,N - IND=IOFFSET(N,I,J) - IF (DISS(IND).GE.DMIN) GOTO 500 - DMIN=DISS(IND) - JM=J - 500 CONTINUE - ENDDO - NN(I)=JM - DISNN(I)=DMIN - ENDDO -! - 400 CONTINUE -! Next, determine least diss. using list of NNs - DMIN=INF - DO I=1,N-1 - IF (.NOT.FLAG(I)) GOTO 600 - IF (DISNN(I).GE.DMIN) GOTO 600 - DMIN=DISNN(I) - IM=I - JM=NN(I) - 600 CONTINUE - ENDDO - NCL=NCL-1 -! -! This allows an agglomeration to be carried out. -! - I2=MIN0(IM,JM) - J2=MAX0(IM,JM) - IA(N-NCL)=I2 - IB(N-NCL)=J2 - CRIT(N-NCL)=DMIN -! -! Update dissimilarities from new cluster. -! - FLAG(J2)=.FALSE. - DMIN=INF - DO K=1,N - IF (.NOT.FLAG(K)) GOTO 800 - IF (K.EQ.I2) GOTO 800 - X=MEMBR(I2)+MEMBR(J2)+MEMBR(K) - IF (I2.LT.K) THEN - IND1=IOFFSET(N,I2,K) - ELSE - IND1=IOFFSET(N,K,I2) - ENDIF - IF (J2.LT.K) THEN - IND2=IOFFSET(N,J2,K) - ELSE - IND2=IOFFSET(N,K,J2) - ENDIF - IND3=IOFFSET(N,I2,J2) - XX=DISS(IND3) -! -! WARD'S MINIMUM VARIANCE METHOD - IOPT=1. -! - IF (IOPT.EQ.1) THEN - DISS(IND1)=(MEMBR(I2)+MEMBR(K))*DISS(IND1)+ & - (MEMBR(J2)+MEMBR(K))*DISS(IND2)- & - MEMBR(K)*XX - DISS(IND1)=DISS(IND1)/X - ENDIF -! -! SINGLE LINK METHOD - IOPT=2. -! - IF (IOPT.EQ.2) THEN - DISS(IND1)=MIN(DISS(IND1),DISS(IND2)) - ENDIF -! -! COMPLETE LINK METHOD - IOPT=3. -! - IF (IOPT.EQ.3) THEN - DISS(IND1)=MAX(DISS(IND1),DISS(IND2)) - ENDIF -! -! AVERAGE LINK (OR GROUP AVERAGE) METHOD - IOPT=4. -! - IF (IOPT.EQ.4) THEN - DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2))/ & - (MEMBR(I2)+MEMBR(J2)) - ENDIF -! -! MCQUITTY'S METHOD - IOPT=5. -! - IF (IOPT.EQ.5) THEN - DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2) - ENDIF -! -! MEDIAN (GOWER'S) METHOD - IOPT=6. -! - IF (IOPT.EQ.6) THEN - DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2)-0.25*XX - ENDIF -! -! CENTROID METHOD - IOPT=7. -! - IF (IOPT.EQ.7) THEN - DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2)- & - MEMBR(I2)*MEMBR(J2)*XX/(MEMBR(I2)+MEMBR(J2)))/ & - (MEMBR(I2)+MEMBR(J2)) - ENDIF -! - IF (I2.GT.K) GOTO 800 - IF (DISS(IND1).GE.DMIN) GOTO 800 - DMIN=DISS(IND1) - JJ=K - 800 CONTINUE - ENDDO - MEMBR(I2)=MEMBR(I2)+MEMBR(J2) - DISNN(I2)=DMIN - NN(I2)=JJ -! -! Update list of NNs insofar as this is required. -! - DO I=1,N-1 - IF (.NOT.FLAG(I)) GOTO 900 - IF (NN(I).EQ.I2) GOTO 850 - IF (NN(I).EQ.J2) GOTO 850 - GOTO 900 - 850 CONTINUE -! (Redetermine NN of I:) - DMIN=INF - DO J=I+1,N - IND=IOFFSET(N,I,J) - IF (.NOT.FLAG(J)) GOTO 870 - IF (I.EQ.J) GOTO 870 - IF (DISS(IND).GE.DMIN) GOTO 870 - DMIN=DISS(IND) - JJ=J - 870 CONTINUE - ENDDO - NN(I)=JJ - DISNN(I)=DMIN - 900 CONTINUE - ENDDO -! -! Repeat previous steps until N-1 agglomerations carried out. -! - IF (NCL.GT.1) GOTO 400 -! -! - RETURN - END SUBROUTINE HC -!----------------------------------------------------------------------------- -! -! - integer FUNCTION IOFFSET(N,I,J) -! Map row I and column J of upper half diagonal symmetric matrix -! onto vector. - integer :: N,I,J - IOFFSET=J+(I-1)*N-(I*(I+1))/2 - RETURN - END FUNCTION IOFFSET -!----------------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C -! C -! Given a HIERARCHIC CLUSTERING, described as a sequence of C -! agglomerations, derive the assignments into clusters for the C -! top LEV-1 levels of the hierarchy. C -! Prepare also the required data for representing the C -! dendrogram of this top part of the hierarchy. C -! C -! Parameters: C -! C -! IA, IB, CRIT: vectors of dimension N defining the agglomer- C -! ations. C -! LEV: number of clusters in largest partition. C -! HVALS: vector of dim. LEV, used internally only. C -! ICLASS: array of cluster assignments; dim. N by LEV. C -! IORDER, CRITVAL, HEIGHT: vectors describing the dendrogram, C -! all of dim. LEV. C -! C -! F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C -! C -! HISTORY C -! C -! Bounds bug fix, Oct. 1990, F. Murtagh. C -! Inserted line "IF (LOC.GT.LEV) GOTO 58" on line 48. This was C -! occassioned by incorrect termination of this loop when I C -! reached its (lower) extremity, i.e. N-LEV. Without the C -! /CHECK=(BOUNDS) option on VAX/VMS compilation, this inserted C -! statement was not necessary. C -!---------------------------------------------------------------C - SUBROUTINE HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,& - CRITVAL,HEIGHT) -! include 'sizesclu.dat' -! include 'COMMON.IOUNITS' - integer :: N,LEV -!el integer :: ICLASS(maxconf,maxconf-1) - integer :: ICLASS(N,N-1) - INTEGER :: IA(N),IB(N),HVALS(LEV),IORDER(LEV),& - HEIGHT(LEV) - REAL(kind=4) :: CRIT(N),CRITVAL(LEV) - integer :: I,J,LOC,LEVEL,ICL,ILEV,NCL,K -! -! Pick out the clusters which the N objects belong to, -! at levels N-2, N-3, ... N-LEV+1 of the hierarchy. -! The clusters are identified by the lowest seq. no. of -! their members. -! There are 2, 3, ... LEV clusters, respectively, for the -! above levels of the hierarchy. -! - HVALS(1)=1 - HVALS(2)=IB(N-1) - LOC=3 - DO 59 I=N-2,N-LEV,-1 - DO 52 J=1,LOC-1 - IF (IA(I).EQ.HVALS(J)) GOTO 54 - 52 CONTINUE - HVALS(LOC)=IA(I) - LOC=LOC+1 - 54 CONTINUE - DO 56 J=1,LOC-1 - IF (IB(I).EQ.HVALS(J)) GOTO 58 - 56 CONTINUE - IF (LOC.GT.LEV) GOTO 58 - HVALS(LOC)=IB(I) - LOC=LOC+1 - 58 CONTINUE - 59 CONTINUE -! - DO 400 LEVEL=N-LEV,N-2 - DO 200 I=1,N - ICL=I - DO 100 ILEV=1,LEVEL - 100 IF (IB(ILEV).EQ.ICL) ICL=IA(ILEV) - NCL=N-LEVEL - ICLASS(I,NCL-1)=ICL - 200 CONTINUE - 400 CONTINUE -! - DO 120 I=1,N - DO 120 J=1,LEV-1 - DO 110 K=2,LEV - IF (ICLASS(I,J).NE.HVALS(K)) GOTO 110 - ICLASS(I,J)=K - GOTO 120 - 110 CONTINUE - 120 CONTINUE -! - WRITE (iout,450) (j,j=2,LEV) - 450 FORMAT(4X,' SEQ NOS',8(i2,'CL'),10000(i3,'CL')) - WRITE (iout,470) (' ---',j=2,LEV) - 470 FORMAT(4X,' -------',10000a4) - DO 500 I=1,N - WRITE (iout,600) I,(ICLASS(I,J),J=1,LEV-1) - 600 FORMAT(I11,8I4,10000i5) - 500 CONTINUE -! -! Determine an ordering of the LEV clusters (at level LEV-1) -! for later representation of the dendrogram. -! These are stored in IORDER. -! Determine the associated ordering of the criterion values -! for the vertical lines in the dendrogram. -! The ordinal values of these criterion values may be used in -! preference, and these are stored in HEIGHT. -! Finally, note that the LEV clusters are renamed so that they -! have seq. nos. 1 to LEV. -! - IORDER(1)=IA(N-1) - IORDER(2)=IB(N-1) - CRITVAL(1)=0.0 - CRITVAL(2)=CRIT(N-1) - HEIGHT(1)=LEV - HEIGHT(2)=LEV-1 - LOC=2 - DO 700 I=N-2,N-LEV+1,-1 - DO 650 J=1,LOC - IF (IA(I).EQ.IORDER(J)) THEN -! Shift rightwards and insert IB(I) beside IORDER(J): - DO 630 K=LOC+1,J+1,-1 - IORDER(K)=IORDER(K-1) - CRITVAL(K)=CRITVAL(K-1) - HEIGHT(K)=HEIGHT(K-1) - 630 CONTINUE - IORDER(J+1)=IB(I) - CRITVAL(J+1)=CRIT(I) - HEIGHT(J+1)=I-(N-LEV) - LOC=LOC+1 - ENDIF - 650 CONTINUE - 700 CONTINUE - DO 705 I=1,LEV - DO 703 J=1,LEV - IF (HVALS(I).EQ.IORDER(J)) THEN - IORDER(J)=I - GOTO 705 - ENDIF - 703 CONTINUE - 705 CONTINUE -! - RETURN - END SUBROUTINE HCASS -!----------------------------------------------------------------------------- -!+++++++++++++++++++++++++++++++++++++++++++++++++C -! C -! Construct a DENDROGRAM of the top 8 levels of C -! a HIERARCHIC CLUSTERING. C -! C -! Parameters: C -! C -! IORDER, HEIGHT, CRITVAL: vectors of length LEV C -! defining the dendrogram. C -! These are: the ordering of objects C -! along the bottom of the dendrogram C -! (IORDER); the height of the vertical C -! above each object, in ordinal values C -! (HEIGHT); and in real values (CRITVAL).C -! C -! NOTE: these vectors MUST have been set up with C -! LEV = 9 in the prior call to routine C -! HCASS. -! C -! F. Murtagh, ESA/ESO/STECF, Garching, Feb. 1986.C -! C -!-------------------------------------------------C - SUBROUTINE HCDEN(LEV,IORDER,HEIGHT,CRITVAL) -! include 'COMMON.IOUNITS' - integer :: LEV - CHARACTER(len=80) :: LINE - INTEGER :: IORDER(LEV),HEIGHT(LEV) - REAL(kind=4) :: CRITVAL(LEV) -! INTEGER OUT(3*LEV,3*LEV) -! INTEGER UP,ACROSS,BLANK - CHARACTER(len=1) :: OUT(3*LEV,3*LEV) - CHARACTER(len=1) :: UP,ACROSS,BLANK - DATA UP,ACROSS,BLANK /'|','-',' '/ - integer :: I,I2,J,J2,K,I3,L,IC,IDUM -! -! - DO I=1,3*LEV - DO J=1,3*LEV - OUT(I,J)=BLANK - ENDDO - ENDDO -! -! - DO I=3,3*LEV,3 - I2=I/3 -! - J2=3*LEV+1-3*HEIGHT(I2) - DO J=3*LEV,J2,-1 - OUT(J,I)=UP - ENDDO -! - DO K=I,3,-1 - I3=INT((K+2)/3) - IF ( (3*LEV+1-HEIGHT(I3)*3).LT.J2) GOTO 100 - OUT(J2,K)=ACROSS - ENDDO - 100 CONTINUE -! - ENDDO -! -! - IC=3 - DO I=1,3*LEV - IF (I.EQ.IC+1) THEN - IDUM=IC/3 - IDUM=LEV-IDUM - DO L=1,LEV - IF (HEIGHT(L).EQ.IDUM) GOTO 190 - ENDDO - 190 IDUM=L - WRITE(iout,200) CRITVAL(IDUM),(OUT(I,J),J=1,3*LEV) - IC=IC+3 - ELSE - LINE = ' ' - WRITE(iout,210) (OUT(I,J),J=1,3*LEV) - ENDIF - 200 FORMAT(1H ,8X,F12.2,4X,27000A1) - 210 FORMAT(1H ,24X,27000A1) - ENDDO - WRITE(iout,250) - WRITE(iout,220)(IORDER(J),J=1,LEV) - WRITE(iout,250) - 220 FORMAT(1H ,24X,9000I3) - WRITE(iout,230) LEV - 230 FORMAT(1H ,13X,'CRITERION CLUSTERS 1 TO ',i3) - WRITE(iout,240) LEV-1 - 240 FORMAT(1H ,13X,'VALUES. (TOP ',i3,' LEVELS OF HIERARCHY).') - 250 FORMAT(/) -! -! - RETURN - END SUBROUTINE HCDEN -!----------------------------------------------------------------------------- - end module hc_ -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- diff --git a/source/cluster/io_clust.F90 b/source/cluster/io_clust.F90 new file mode 100644 index 0000000..db74bf6 --- /dev/null +++ b/source/cluster/io_clust.F90 @@ -0,0 +1,1824 @@ + module io_clust +!----------------------------------------------------------------------------- + use clust_data + use io_units +! use names + use io_base !, only: ilen + use geometry_data, only: nres,c + use energy_data, only: nnt,nct,nss + use control_data, only: lside + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! wrtclust.f +!----------------------------------------------------------------------------- + SUBROUTINE WRTCLUST(NCON,ICUT,PRINTANG,PRINTPDB,printmol2,ib) + + use hc_, only: ioffset + use control_data, only: lprint_cart,lprint_int,titel + use geometry, only: int_from_cart1,nres +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'sizesclu.dat' + integer,parameter :: num_in_line=5 + LOGICAL :: PRINTANG(max_cut) + integer :: PRINTPDB(max_cut),printmol2(max_cut) +! include 'COMMON.CONTROL' +! include 'COMMON.HEADER' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.CLUSTER' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.FREE' +! include 'COMMON.TEMPFAC' + real(kind=8) :: rmsave(maxgr) + CHARACTER(len=64) :: prefixp,NUMM,MUMM,EXTEN,extmol + character(len=80) :: cfname + character(len=8) :: ctemper + DATA EXTEN /'.pdb'/,extmol /'.mol2'/,NUMM /'000'/,& + MUMM /'000'/ +! external ilen + integer :: ncon,icut,ib + integer :: i,ii,ii1,ii2,igr,ind1,ind2,ico,icon,& + irecord,nrecord,j,k,jj,ind,ncon_lim,ncon_out + real(kind=8) :: temper,curr_dist,emin,qpart,boltz,& + ave_dim,amax_dim,emin1 + + + allocate(tempfac(2,nres)) + + do i=1,64 + cfname(i:i)=" " + enddo +! print *,"calling WRTCLUST",ncon +! write (iout,*) "ICUT",icut," PRINTPDB ",PRINTPDB(icut) + rewind 80 + call flush(iout) + temper=1.0d0/(beta_h(ib)*1.987d-3) + if (temper.lt.100.0d0) then + write(ctemper,'(f3.0)') temper + ctemper(3:3)=" " + else if (temper.lt.1000.0) then + write (ctemper,'(f4.0)') temper + ctemper(4:4)=" " + else + write (ctemper,'(f5.0)') temper + ctemper(5:5)=" " + endif + + do i=1,ncon*(ncon-1)/2 + read (80) diss(i) + enddo + close(80,status='delete') +! +! PRINT OUT THE RESULTS OF CLUSTER ANALYSIS +! + ii1= index(intinname,'/') + ii2=ii1 + ii1=ii1+1 + do while (ii2.gt.0) + ii1=ii1+ii2 + ii2=index(intinname(ii1:),'/') + enddo + ii = ii1+index(intinname(ii1:),'.')-1 + if (ii.eq.0) then + ii=ilen(intinname) + else + ii=ii-1 + endif + prefixp=intinname(ii1:ii) +!d print *,icut,printang(icut),printpdb(icut),printmol2(icut) +!d print *,'ecut=',ecut + WRITE (iout,100) NGR + DO 19 IGR=1,NGR + WRITE (iout,200) IGR,totfree_gr(igr)/beta_h(ib),LICZ(IGR) + NRECORD=LICZ(IGR)/num_in_line + IND1=1 + DO 63 IRECORD=1,NRECORD + IND2=IND1+num_in_line-1 + WRITE (iout,300) (list_conf(NCONF(IGR,ICO)),& + totfree(NCONF(IGR,ICO))/beta_h(ib),ICO=IND1,IND2) + IND1=IND2+1 + 63 CONTINUE + WRITE (iout,300) (list_conf(NCONF(IGR,ICO)),& + totfree(NCONF(IGR,ICO))/beta_h(ib),ICO=IND1,LICZ(IGR)) + IND1=1 + ICON=list_conf(NCONF(IGR,1)) +! WRITE (iout,'(16F5.0)') (rad2deg*phiall(IND,icon),IND=4,nphi+3) +! 12/8/93 Estimation of "diameters" of the subsequent families. + ave_dim=0.0 + amax_dim=0.0 +! write (iout,*) "ecut",ecut + do i=2,licz(igr) + ii=nconf(igr,i) + if (totfree(ii)-emin .gt. ecut) goto 10 + do j=1,i-1 + jj=nconf(igr,j) + if (jj.eq.1) exit + if (ii.lt.jj) then + ind=ioffset(ncon,ii,jj) + else + ind=ioffset(ncon,jj,ii) + endif +! write (iout,*) " ncon",ncon,"i",i," j",j," ii",ii," jj",jj, +! & " ind",ind + call flush(iout) + curr_dist=dabs(diss(ind)+0.0d0) +! write(iout,'(i10,4i4,f12.4)') ind,ii,jj,list_conf(ii), +! & list_conf(jj),curr_dist + if (curr_dist .gt. amax_dim) amax_dim=curr_dist + ave_dim=ave_dim+curr_dist**2 + enddo + enddo + 10 if (licz(igr) .gt. 1) & + ave_dim=sqrt(ave_dim/(licz(igr)*(licz(igr)-1)/2)) + write (iout,'(/A,F8.1,A,F8.1)') & + 'Max. distance in the family:',amax_dim,& + '; average distance in the family:',ave_dim + rmsave(igr)=0.0d0 + qpart=0.0d0 + do i=1,licz(igr) + icon=nconf(igr,i) + boltz=dexp(-totfree(icon)) + rmsave(igr)=rmsave(igr)+boltz*rmstb(icon) + qpart=qpart+boltz + enddo + rmsave(igr)=rmsave(igr)/qpart + write (iout,'(a,f5.2,a)') "Average RMSD",rmsave(igr)," A" + 19 CONTINUE + WRITE (iout,400) + WRITE (iout,500) (list_conf(I),IASS(I),I=1,NCON) +! print *,icut,printang(icut) + IF (PRINTANG(ICUT) .and. (lprint_cart .or. lprint_int)) then + emin=totfree_gr(1) +! print *,'emin',emin,' ngr',ngr + if (lprint_cart) then + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& + //"K"//".x" + else + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& + //"K"//".int" + endif + do igr=1,ngr + icon=nconf(igr,1) + if (totfree_gr(igr)-emin.le.ecut) then + if (lprint_cart) then + call cartout(igr,icon,totfree(icon)/beta_h(ib),& + totfree_gr(igr)/beta_h(ib),& + rmstb(icon),cfname) + else +! print '(a)','calling briefout' + do i=1,2*nres + do j=1,3 + c(j,i)=allcart(j,i,icon) + enddo + enddo + call int_from_cart1(.false.) +!el call briefout(igr,iscore(icon),totfree(icon)/beta_h(ib),& +!el totfree_gr(igr),nss_all(icon),ihpb_all(1,icon),& +!el jhpb_all(1,icon),cfname) + call briefout(igr,totfree(icon)/beta_h(ib),& + totfree_gr(igr)) +! print '(a)','exit briefout' + endif + endif + enddo + close(igeom) + ENDIF + IF (PRINTPDB(ICUT).gt.0) THEN +! Write out a number of conformations from each family in PDB format and +! create InsightII command file for their displaying in different colors + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& + //"K_"//'ave'//exten + write (iout,*) "cfname",cfname + OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') + write (ipdb,'(a,f8.2)') & + "REMAR AVERAGE CONFORMATIONS AT TEMPERATURE",temper + close (ipdb) + I=1 + ICON=NCONF(1,1) + EMIN=totfree_gr(I) + emin1=totfree(icon) + DO WHILE(I.LE.NGR .AND. totfree_gr(i)-EMIN.LE.ECUT) +! write (iout,*) "i",i," ngr",ngr,totfree_gr(I),EMIN,ecut + write (NUMM,'(bz,i4.4)') i + ncon_lim=min0(licz(i),printpdb(icut)) + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& + //"K_"//numm(:ilen(numm))//exten + OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') + write (ipdb,'("REMARK CLUSTER",i5," FREE ENERGY",1pe14.5," AVE RMSD",0pf5.2)')& + i,totfree_gr(i)/beta_h(ib),rmsave(i) !' +! Write conformations of the family i to PDB files + ncon_out=1 + do while (ncon_out.lt.printpdb(icut) .and. & + ncon_out.lt.licz(i).and. & + totfree(nconf(i,ncon_out+1))-EMIN1.LE.ECUT) + ncon_out=ncon_out+1 +! write (iout,*) i,ncon_out,nconf(i,ncon_out), +! & totfree(nconf(i,ncon_out)),emin1,ecut + enddo + write (iout,*) "ncon_out",ncon_out + call flush(iout) + do j=1,nres + tempfac(1,j)=5.0d0 + tempfac(2,j)=5.0d0 + enddo + do j=1,ncon_out + icon=nconf(i,j) + do ii=1,2*nres + do k=1,3 + c(k,ii)=allcart(k,ii,icon) + enddo + enddo + call pdboutC(totfree(icon)/beta_h(ib),rmstb(icon),titel) + write (ipdb,'("TER")') + enddo + close(ipdb) +! Average structures and structures closest to average + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& + //"K_"//'ave'//exten + OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED',& + position="APPEND") + call ave_coord(i) + write (ipdb,'(a,i5)') "REMARK CLUSTER",i + call pdboutC(totfree_gr(i)/beta_h(ib),rmsave(i),titel) + write (ipdb,'("TER")') + call closest_coord(i) + call pdboutC(totfree_gr(i)/beta_h(ib),rmsave(i),titel) + write (ipdb,'("TER")') + close (ipdb) + I=I+1 + ICON=NCONF(I,1) + emin1=totfree(icon) + ENDDO + ENDIF + IF (printmol2(icut).gt.0) THEN +! Write out a number of conformations from each family in PDB format and +! create InsightII command file for their displaying in different colors + I=1 + ICON=NCONF(1,1) + EMIN=ENERGY(ICON) + emin1=emin + DO WHILE(I.LE.NGR .AND. totfree_gr(i)-EMIN.LE.ECUT) + write (NUMM,'(bz,i4.4)') i + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& + //"K_"//numm(:ilen(numm))//extmol + OPEN(imol2,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') + ncon_out=1 + do while (ncon_out.lt.printmol2(icut) .and. & + ncon_out.lt.licz(i).and. & + totfree(nconf(i,ncon_out+1))-EMIN1.LE.ECUT) + ncon_out=ncon_out+1 + enddo + do j=1,ncon_out + icon=nconf(i,j) + do ii=1,2*nres + do k=1,3 + c(k,ii)=allcart(k,ii,icon) + enddo + enddo + CALL MOL2OUT(totfree(icon)/beta_h(ib),'STRUCTURE'//numm) + enddo + CLOSE(imol2) + I=I+1 + ICON=NCONF(I,1) + emin1=totfree(icon) + ENDDO + ENDIF + 100 FORMAT (//'THERE ARE ',I4,' FAMILIES OF CONFORMATIONS') + 200 FORMAT (/'FAMILY ',I4,' WITH TOTAL FREE ENERGY',1pE15.5,& + ' CONTAINS ',I4,' CONFORMATION(S): ') +! 300 FORMAT ( 8(I4,F6.1)) + 300 FORMAT (5(I4,1pe12.3)) + 400 FORMAT (//'ASSIGNMENT OF CONSECUTIVE CONFORMATIONS TO FAMILIES:') + 500 FORMAT (8(2I4,2X)) + 600 FORMAT ('REMARK FAMILY',I4,' CONFORMATION',I4,' ENERGY ',E15.6) + RETURN + END SUBROUTINE WRTCLUST +!------------------------------------------------------------------------------ + subroutine ave_coord(igr) + + use control_data, only:lside + use regularize_, only:fitsq,matvec +! implicit none +! include 'DIMENSIONS' +! include 'sizesclu.dat' +! include 'COMMON.CONTROL' +! include 'COMMON.CLUSTER' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.TEMPFAC' +! include 'COMMON.IOUNITS' + logical :: non_conv + real(kind=8) :: przes(3),obrot(3,3) + real(kind=8) :: xx(3,2*nres),yy(3,2*nres),csq(3,2*nres) !(3,maxres2) + real(kind=8) :: eref + integer :: i,ii,j,k,icon,jcon,igr + real(kind=8) :: rms,boltz,qpart,cwork(3,2*nres),cref1(3,2*nres) !(3,maxres2) +! write (iout,*) "AVE_COORD: igr",igr + jcon=nconf(igr,1) + eref=totfree(jcon) + boltz = dexp(-totfree(jcon)+eref) + qpart=boltz + do i=1,2*nres + do j=1,3 + c(j,i)=allcart(j,i,jcon)*boltz + cref1(j,i)=allcart(j,i,jcon) + csq(j,i)=allcart(j,i,jcon)**2*boltz + enddo + enddo + DO K=2,LICZ(IGR) + jcon=nconf(igr,k) + if (lside) then + ii=0 + do i=nnt,nct + ii=ii+1 + do j=1,3 + xx(j,ii)=allcart(j,i,jcon) + yy(j,ii)=cref1(j,i) + enddo + enddo + do i=nnt,nct +! if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + xx(j,ii)=allcart(j,i+nres,jcon) + yy(j,ii)=cref1(j,i+nres) + enddo +! endif + enddo + call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) + else + do i=nnt,nct + do j=1,3 + cwork(j,i)=allcart(j,i,jcon) + enddo + enddo + call fitsq(rms,cwork(1,nnt),cref1(1,nnt),nct-nnt+1,przes,obrot & + ,non_conv) + endif +! write (iout,*) "rms",rms +! do i=1,3 +! write (iout,'(i3,f10.5,5x,3f10.5)')i,przes(i),(obrot(i,j),j=1,3) +! enddo + if (rms.lt.0.0) then + print *,'error, rms^2 = ',rms,icon,jcon + stop + endif + if (non_conv) print *,non_conv,icon,jcon + boltz=dexp(-totfree(jcon)+eref) + qpart = qpart + boltz + do i=1,2*nres + do j=1,3 + xx(j,i)=allcart(j,i,jcon) + enddo + enddo + call matvec(cwork,obrot,xx,2*nres) + do i=1,2*nres +! write (iout,'(i5,2(3f10.5,5x))') i,(cwork(j,i),j=1,3), +! & (allcart(j,i,jcon),j=1,3) + do j=1,3 + cwork(j,i)=cwork(j,i)+przes(j) + c(j,i)=c(j,i)+cwork(j,i)*boltz + csq(j,i)=csq(j,i)+cwork(j,i)**2*boltz + enddo + enddo + ENDDO ! K + do i=1,2*nres + do j=1,3 + c(j,i)=c(j,i)/qpart + csq(j,i)=csq(j,i)/qpart-c(j,i)**2 + enddo +! write (iout,'(i5,3f10.5)') i,(csq(j,i),j=1,3) + enddo + do i=nnt,nct + tempfac(1,i)=0.0d0 + tempfac(2,i)=0.0d0 + do j=1,3 + tempfac(1,i)=tempfac(1,i)+csq(j,i) + tempfac(2,i)=tempfac(2,i)+csq(j,i+nres) + enddo + tempfac(1,i)=dsqrt(tempfac(1,i)) + tempfac(2,i)=dsqrt(tempfac(2,i)) + enddo + return + end subroutine ave_coord +!------------------------------------------------------------------------------ + subroutine closest_coord(igr) + + use regularize_, only:fitsq +! implicit none +! include 'DIMENSIONS' +! include 'sizesclu.dat' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +! include 'COMMON.CLUSTER' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' + logical :: non_conv + real(kind=8) :: przes(3),obrot(3,3) + real(kind=8) :: xx(3,2*nres),yy(3,2*nres) !(3,maxres2) + integer :: i,ii,j,k,icon,jcon,jconmin,igr + real(kind=8) :: rms,rmsmin,cwork(3,2*nres) + rmsmin=1.0d10 + jconmin=nconf(igr,1) + DO K=1,LICZ(IGR) + jcon=nconf(igr,k) + if (lside) then + ii=0 + do i=nnt,nct + ii=ii+1 + do j=1,3 + xx(j,ii)=allcart(j,i,jcon) + yy(j,ii)=c(j,i) + enddo + enddo + do i=nnt,nct +! if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + xx(j,ii)=allcart(j,i+nres,jcon) + yy(j,ii)=c(j,i+nres) + enddo +! endif + enddo + call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) + else + do i=nnt,nct + do j=1,3 + cwork(j,i)=allcart(j,i,jcon) + enddo + enddo + call fitsq(rms,cwork(1,nnt),c(1,nnt),nct-nnt+1,przes,obrot,& + non_conv) + endif + if (rms.lt.0.0) then + print *,'error, rms^2 = ',rms,icon,jcon + stop + endif +! write (iout,*) "jcon",jcon," rms",rms," rmsmin",rmsmin + if (non_conv) print *,non_conv,icon,jcon + if (rms.lt.rmsmin) then + rmsmin=rms + jconmin=jcon + endif + ENDDO ! K +! write (iout,*) "rmsmin",rmsmin," rms",rms + call flush(iout) + do i=1,2*nres + do j=1,3 + c(j,i)=allcart(j,i,jconmin) + enddo + enddo + return + end subroutine closest_coord +!----------------------------------------------------------------------------- +! read_coords.F +!----------------------------------------------------------------------------- + subroutine read_coords(ncon,*) + + use energy_data, only: ihpb,jhpb,max_ene + use control_data, only: from_bx,from_cx + use control, only: tcpu +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" +#ifdef MPI + use MPI_data + include "mpif.h" + integer :: IERROR,ERRCODE !,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#else + use MPI_data, only: nprocs +#endif +! include "COMMON.CONTROL" +! include "COMMON.CHAIN" +! include "COMMON.INTERACT" +! include "COMMON.IOUNITS" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.CLUSTER" + character(len=3) :: liczba + integer :: ncon + integer :: i,j,jj,jjj,jj_old,icount,k,kk,l,ii,if,ib,& + nn,nn1,inan + integer :: ixdrf,iret,itmp + real(kind=4) :: prec,reini,refree,rmsdev + integer :: nrec,nlines,iscor,lenrec,lenrec_in + real(kind=8) :: energ,t_acq !,tcpu +!el integer ilen,iroof +!el external ilen,iroof + real(kind=8) :: rjunk + integer :: ntot_all(0:nprocs-1) !(0:maxprocs-1) + logical :: lerr + real(kind=8) :: energia(0:max_ene),etot + real(kind=4) :: csingle(3,2*nres+2) + integer :: Previous,Next + character(len=256) :: bprotfiles +! print *,"Processor",me," calls read_protein_data" +#ifdef MPI + if (me.eq.master) then + Previous=MPI_PROC_NULL + else + Previous=me-1 + endif + if (me.eq.nprocs-1) then + Next=MPI_PROC_NULL + else + Next=me+1 + endif +! Set the scratchfile names + write (liczba,'(bz,i3.3)') me + + allocate(STATUS(MPI_STATUS_SIZE)) +#endif +! 1/27/05 AL Change stored coordinates to single precision and don't store +! energy components in the binary databases. + lenrec=12*(nres+nct-nnt+1)+4*(2*nss+2)+16 + lenrec_in=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 +#ifdef DEBUG + write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss", nss + write (iout,*) "lenrec_in",lenrec_in +#endif + bprotfiles=scratchdir(:ilen(scratchdir))// & + "/"//prefix(:ilen(prefix))//liczba//".xbin" +! EL +! allocate cluster arrays + allocate(energy(0:maxconf),totfree(0:maxconf)) !(0:maxconf) + allocate(entfac(maxconf)) !(maxconf) + allocate(rmstb(maxconf)) !(maxconf) + allocate(allcart(3,2*nres,maxstr_proc)) !(3,maxres2,maxstr_proc) + allocate(nss_all(maxstr_proc)) !(maxstr_proc) + allocate(ihpb_all(maxss,maxstr_proc),jhpb_all(maxss,maxstr_proc))!(maxss,maxstr_proc) + allocate(iscore(maxconf)) !(maxconf) + + +#ifdef CHUJ + ICON=1 + 123 continue + if (from_cart .and. .not. from_bx .and. .not. from_cx) then + if (efree) then + read (intin,*,end=13,err=11) energy(icon),totfree(icon),& + rmstb(icon),& + nss_all(icon),(ihpb_all(ii,icon),jhpb_all(i,icon),& + i=1,nss_all(icon)),iscore(icon) + else + read (intin,*,end=13,err=11) energy(icon),rmstb(icon),& + nss_all(icon),(ihpb_all(ii,icon),jhpb_all(i,icon),& + i=1,nss_all(icon)),iscore(icon) + endif + read (intin,'(8f10.5)',end=13,err=10) & + ((allcart(j,i,icon),j=1,3),i=1,nres),& + ((allcart(j,i+nres,icon),j=1,3),i=nnt,nct) + print *,icon,energy(icon),nss_all(icon),rmstb(icon) + else + read(intin,'(a80)',end=13,err=12) lineh + read(lineh(:5),*,err=8) ic + if (efree) then + read(lineh(6:),*,err=8) energy(icon) + else + read(lineh(6:),*,err=8) energy(icon) + endif + goto 9 + 8 ic=1 + print *,'error, assuming e=1d10',lineh + energy(icon)=1d10 + nss=0 + 9 continue +!old read(lineh(18:),*,end=13,err=11) nss_all(icon) + ii = index(lineh(15:)," ")+15 + read(lineh(ii:),*,end=13,err=11) nss_all(icon) + IF (NSS_all(icon).LT.9) THEN + read (lineh(20:),*,end=102) & + (IHPB_all(I,icon),JHPB_all(I,icon),I=1,NSS_all(icon)),& + iscore(icon) + ELSE + read (lineh(20:),*,end=102) & + (IHPB_all(I,icon),JHPB_all(I,icon),I=1,8) + read (intin,*) (IHPB_all(I,icon),JHPB_all(I,icon),& + I=9,NSS_all(icon)),iscore(icon) + ENDIF + + 102 continue + + PRINT *,'IC:',IC,' ENERGY:',ENERGY(ICON) + call read_angles(intin,*13) + do i=1,nres + phiall(i,icon)=phi(i) + thetall(i,icon)=theta(i) + alphall(i,icon)=alph(i) + omall(i,icon)=omeg(i) + enddo + endif + ICON=ICON+1 + GOTO 123 +! +! CALCULATE DISTANCES +! + 10 print *,'something wrong with angles' + goto 13 + 11 print *,'something wrong with NSS',nss + goto 13 + 12 print *,'something wrong with header' + + 13 NCON=ICON-1 + +#endif + call flush(iout) + jj_old=1 + open (icbase,file=bprotfiles,status="unknown",& + form="unformatted",access="direct",recl=lenrec) +! Read conformations from binary DA files (one per batch) and write them to +! a binary DA scratchfile. + jj=0 + jjj=0 +#ifdef MPI + write (liczba,'(bz,i3.3)') me + IF (ME.EQ.MASTER) THEN +! Only the master reads the database; it'll send it to the other procs +! through a ring. +#endif + t_acq = tcpu() + icount=0 + + if (from_bx) then + + open (intin,file=intinname,status="old",form="unformatted",& + access="direct",recl=lenrec_in) + + else if (from_cx) then +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,intinname, "r", iret) +#else + call xdrfopen(ixdrf,intinname, "r", iret) +#endif + prec=10000.0 + write (iout,*) "xdrfopen: iret",iret + if (iret.eq.0) then + write (iout,*) "Error: coordinate file ",& + intinname(:ilen(intinname))," does not exist." + call flush(iout) +#ifdef MPI + call MPI_ABORT(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop + endif + else + write (iout,*) "Error: coordinate format not specified" + call flush(iout) +#ifdef MPI + call MPI_ABORT(MPI_COMM_WORLD,IERROR,ERRCODE) +#else + stop +#endif + endif + +!#define DEBUG +#ifdef DEBUG + write (iout,*) "Opening file ",intinname(:ilen(intinname)) + write (iout,*) "lenrec",lenrec_in + call flush(iout) +#endif +!#undef DEBUG +! write (iout,*) "maxconf",maxconf + i=0 + do while (.true.) + i=i+1 +!el if (i.gt.maxconf) then +!el write (iout,*) "Error: too many conformations ",& +!el "(",maxconf,") maximum." +!#ifdef MPI +!el call MPI_Abort(MPI_COMM_WORLD,errcode,ierror) +!#endif +!el stop +!el endif +! write (iout,*) "i",i +! call flush(iout) + if (from_bx) then + read(intin,err=101,end=101) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + energy(jj+1),& + entfac(jj+1),rmstb(jj+1),iscor + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + else +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, csingle, itmp, prec, iret) + if (iret.eq.0) goto 101 + call xdrfint_(ixdrf, nss, iret) + if (iret.eq.0) goto 101 + do j=1,nss + call xdrfint_(ixdrf, ihpb(j), iret) + if (iret.eq.0) goto 101 + call xdrfint_(ixdrf, jhpb(j), iret) + if (iret.eq.0) goto 101 + enddo + call xdrffloat_(ixdrf,reini,iret) + if (iret.eq.0) goto 101 + call xdrffloat_(ixdrf,refree,iret) + if (iret.eq.0) goto 101 + call xdrffloat_(ixdrf,rmsdev,iret) + if (iret.eq.0) goto 101 + call xdrfint_(ixdrf,iscor,iret) + if (iret.eq.0) goto 101 +#else +! write (iout,*) "calling xdrf3dfcoord" + call xdrf3dfcoord(ixdrf, csingle, itmp, prec, iret) +! write (iout,*) "iret",iret +! call flush(iout) + if (iret.eq.0) goto 101 + call xdrfint(ixdrf, nss, iret) +! write (iout,*) "iret",iret +! write (iout,*) "nss",nss + call flush(iout) + if (iret.eq.0) goto 101 + do k=1,nss + call xdrfint(ixdrf, ihpb(k), iret) + if (iret.eq.0) goto 101 + call xdrfint(ixdrf, jhpb(k), iret) + if (iret.eq.0) goto 101 + enddo + call xdrffloat(ixdrf,reini,iret) + if (iret.eq.0) goto 101 + call xdrffloat(ixdrf,refree,iret) + if (iret.eq.0) goto 101 + call xdrffloat(ixdrf,rmsdev,iret) + if (iret.eq.0) goto 101 + call xdrfint(ixdrf,iscor,iret) + if (iret.eq.0) goto 101 +#endif + energy(jj+1)=reini + entfac(jj+1)=refree + rmstb(jj+1)=rmsdev + do k=1,nres + do l=1,3 + c(l,k)=csingle(l,k) + enddo + enddo + do k=nnt,nct + do l=1,3 + c(l,nres+k)=csingle(l,nres+k-nnt+1) + enddo + enddo + endif +#ifdef DEBUG + write (iout,'(5hREAD ,i5,3f15.4,i10)') & + jj+1,energy(jj+1),entfac(jj+1),& + rmstb(jj+1),iscor + write (iout,*) "Conformation",jjj+1,jj+1 + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + call flush(iout) +#endif + call add_new_cconf(jjj,jj,jj_old,icount,Next) + enddo + 101 continue + write (iout,*) i-1," conformations read from DA file ",& + intinname(:ilen(intinname)) + write (iout,*) jj," conformations read so far" + if (from_bx) then + close(intin) + else +#if (defined(AIX) && !defined(JUBL)) + call xdrfclose_(ixdrf, iret) +#else + call xdrfclose(ixdrf, iret) +#endif + endif +#ifdef MPI +!#ifdef DEBUG + write (iout,*) "jj_old",jj_old," jj",jj +!#endif + call write_and_send_cconf(icount,jj_old,jj,Next) + call MPI_Send(0,1,MPI_INTEGER,Next,570,& + MPI_COMM_WORLD,IERROR) + jj_old=jj+1 +#else + call write_and_send_cconf(icount,jj_old,jj,Next) +#endif + t_acq = tcpu() - t_acq +#ifdef MPI + write (iout,*) "Processor",me,& + " time for conformation read/send",t_acq + ELSE +! A worker gets the confs from the master and sends them to its neighbor + t_acq = tcpu() + call receive_and_pass_cconf(icount,jj_old,jj,& + Previous,Next) + t_acq = tcpu() - t_acq + ENDIF +#endif + ncon=jj +! close(icbase) + close(intin) + + write(iout,*)"A total of",ncon," conformations read." + + allocate(enetb(1:max_ene,ncon)) !(max_ene,maxstr_proc) +#ifdef MPI +! Check if everyone has the same number of conformations + call MPI_Allgather(ncon,1,MPI_INTEGER,& + ntot_all(0),1,MPI_INTEGER,MPI_Comm_World,IERROR) + lerr=.false. + do i=0,nprocs-1 + if (i.ne.me) then + if (ncon.ne.ntot_all(i)) then + write (iout,*) "Number of conformations at processor",i,& + " differs from that at processor",me,& + ncon,ntot_all(i) + lerr = .true. + endif + endif + enddo + if (lerr) then + write (iout,*) + write (iout,*) "Number of conformations read by processors" + write (iout,*) + do i=0,nprocs-1 + write (iout,'(8i10)') i,ntot_all(i) + enddo + write (iout,*) "Calculation terminated." + call flush(iout) + return 1 + endif + return +#endif + 1111 write(iout,*) "Error opening coordinate file ",& + intinname(:ilen(intinname)) + call flush(iout) + return 1 + end subroutine read_coords +!------------------------------------------------------------------------------ + subroutine add_new_cconf(jjj,jj,jj_old,icount,Next) + + use geometry_data, only: vbld,rad2deg,theta,phi,alph,omeg,deg2rad + use energy_data, only: itel,itype,dsc,max_ene + use control_data, only: symetr + use geometry, only: int_from_cart1 +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" +! include "COMMON.CLUSTER" +! include "COMMON.CONTROL" +! include "COMMON.CHAIN" +! include "COMMON.INTERACT" +! include "COMMON.LOCAL" +! include "COMMON.IOUNITS" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" + integer :: i,j,jj,jjj,jj_old,icount,k,kk,l,ii,ib,& + nn,nn1,inan,Next,itj,chalen + real(kind=8) :: etot,energia(0:max_ene) + jjj=jjj+1 + chalen=int((nct-nnt+2)/symetr) + call int_from_cart1(.false.) + do j=nnt+1,nct + if (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0) then + if (j.gt.2) then + if (itel(j).ne.0 .and. itel(j-1).ne.0) then + write (iout,*) "Conformation",jjj,jj+1 + write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),itel(j),& + chalen + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,*) & + "This conformation WILL NOT be added to the database." + return + endif + endif + endif + enddo + do j=nnt,nct + itj=itype(j) + if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(iabs(itj))) & + .gt.2.0d0) then + write (iout,*) "Conformation",jjj,jj+1 + write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j) + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,*) & + "This conformation WILL NOT be added to the database." + return + endif + enddo + do j=3,nres + if (theta(j).le.0.0d0) then + write (iout,*) & + "Zero theta angle(s) in conformation",jjj,jj+1 + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,*) & + "This conformation WILL NOT be added to the database." + return + endif + if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad + enddo + jj=jj+1 +#ifdef DEBUG + write (iout,*) "Conformation",jjj,jj + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (vbld(k+nres),k=nnt,nct) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(e15.5,16i5)') entfac(icount+1) +! & iscore(icount+1,0) +#endif + icount=icount+1 + call store_cconf_from_file(jj,icount) + if (icount.eq.maxstr_proc) then +#ifdef DEBUG + write (iout,* ) "jj_old",jj_old," jj",jj +#endif + call write_and_send_cconf(icount,jj_old,jj,Next) + jj_old=jj+1 + icount=0 + endif + return + end subroutine add_new_cconf +!------------------------------------------------------------------------------ + subroutine store_cconf_from_file(jj,icount) + + use energy_data, only: ihpb,jhpb +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" +! include "COMMON.CLUSTER" +! include "COMMON.CHAIN" +! include "COMMON.SBRIDGE" +! include "COMMON.INTERACT" +! include "COMMON.IOUNITS" +! include "COMMON.VAR" + integer :: i,j,jj,icount +! Store the conformation that has been read in + do i=1,2*nres + do j=1,3 + allcart(j,i,icount)=c(j,i) + enddo + enddo + nss_all(icount)=nss + do i=1,nss + ihpb_all(i,icount)=ihpb(i) + jhpb_all(i,icount)=jhpb(i) + enddo + return + end subroutine store_cconf_from_file +!------------------------------------------------------------------------------ + subroutine write_and_send_cconf(icount,jj_old,jj,Next) + +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" +#ifdef MPI + use MPI_data + include "mpif.h" + integer :: IERROR +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.SBRIDGE" +! include "COMMON.INTERACT" +! include "COMMON.IOUNITS" +! include "COMMON.CLUSTER" +! include "COMMON.VAR" + integer :: icount,jj_old,jj,Next +! Write the structures to a scratch file +#ifdef MPI +! Master sends the portion of conformations that have been read in to the neighbor +#ifdef DEBUG + write (iout,*) "Processor",me," entered WRITE_AND_SEND_CONF" + call flush(iout) +#endif + call MPI_Send(icount,1,MPI_INTEGER,Next,570,MPI_COMM_WORLD,IERROR) + call MPI_Send(nss_all(1),icount,MPI_INTEGER,& + Next,571,MPI_COMM_WORLD,IERROR) + call MPI_Send(ihpb_all(1,1),icount,MPI_INTEGER,& + Next,572,MPI_COMM_WORLD,IERROR) + call MPI_Send(jhpb_all(1,1),icount,MPI_INTEGER,& + Next,573,MPI_COMM_WORLD,IERROR) + call MPI_Send(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,& + Next,577,MPI_COMM_WORLD,IERROR) + call MPI_Send(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,& + Next,579,MPI_COMM_WORLD,IERROR) + call MPI_Send(allcart(1,1,1),3*icount*2*nres,& + MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR) +#endif + call dawrite_ccoords(jj_old,jj,icbase) + return + end subroutine write_and_send_cconf +!------------------------------------------------------------------------------ +#ifdef MPI + subroutine receive_and_pass_cconf(icount,jj_old,jj,Previous,Next) + + use MPI_data +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" + include "mpif.h" + integer :: IERROR !,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +! include "COMMON.CHAIN" +! include "COMMON.SBRIDGE" +! include "COMMON.INTERACT" +! include "COMMON.IOUNITS" +! include "COMMON.VAR" +! include "COMMON.GEO" +! include "COMMON.CLUSTER" + integer :: i,j,k,icount,jj_old,jj,Previous,Next + icount=1 +#ifdef DEBUG + write (iout,*) "Processor",me," entered RECEIVE_AND_PASS_CONF" + call flush(iout) +#endif + do while (icount.gt.0) + call MPI_Recv(icount,1,MPI_INTEGER,Previous,570,MPI_COMM_WORLD,& + STATUS,IERROR) + call MPI_Send(icount,1,MPI_INTEGER,Next,570,MPI_COMM_WORLD,& + IERROR) +#ifdef DEBUG + write (iout,*) "Processor",me," icount",icount +#endif + if (icount.eq.0) return + call MPI_Recv(nss_all(1),icount,MPI_INTEGER,& + Previous,571,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(nss_all(1),icount,MPI_INTEGER,& + Next,571,MPI_COMM_WORLD,IERROR) + call MPI_Recv(ihpb_all(1,1),icount,MPI_INTEGER,& + Previous,572,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(ihpb_all(1,1),icount,MPI_INTEGER,& + Next,572,MPI_COMM_WORLD,IERROR) + call MPI_Recv(jhpb_all(1,1),icount,MPI_INTEGER,& + Previous,573,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(jhpb_all(1,1),icount,MPI_INTEGER,& + Next,573,MPI_COMM_WORLD,IERROR) + call MPI_Recv(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,& + Previous,577,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,& + Next,577,MPI_COMM_WORLD,IERROR) + call MPI_Recv(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,& + Previous,579,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,& + Next,579,MPI_COMM_WORLD,IERROR) + call MPI_Recv(allcart(1,1,1),3*icount*2*nres,& + MPI_REAL,Previous,580,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(allcart(1,1,1),3*icount*2*nres,& + MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR) + jj=jj_old+icount-1 + call dawrite_ccoords(jj_old,jj,icbase) + jj_old=jj+1 +#ifdef DEBUG + write (iout,*) "Processor",me," received",icount," conformations" + do i=1,icount + write (iout,'(8f10.4)') (allcart(l,k,i),l=1,3,k=1,nres) + write (iout,'(8f10.4)')((allcart(l,k,i+nres),l=1,3,k=nnt,nct) + write (iout,'(e15.5,16i5)') entfac(i) + enddo +#endif + enddo + return + end subroutine receive_and_pass_cconf +#endif +!------------------------------------------------------------------------------ + subroutine daread_ccoords(istart_conf,iend_conf) + +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" +#ifdef MPI + use MPI_data + include "mpif.h" +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.CLUSTER" +! include "COMMON.IOUNITS" +! include "COMMON.INTERACT" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" + integer :: istart_conf,iend_conf + integer :: i,j,ij,ii,iii + integer :: len + character(len=16) :: form,acc + character(len=32) :: nam +! +! Read conformations off a DA scratchfile. +! +#ifdef DEBUG + write (iout,*) "DAREAD_COORDS" + write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf + inquire(unit=icbase,name=nam,recl=len,form=form,access=acc) + write (iout,*) "len=",len," form=",form," acc=",acc + write (iout,*) "nam=",nam + call flush(iout) +#endif + do ii=istart_conf,iend_conf + ij = ii - istart_conf + 1 + iii=list_conf(ii) +#ifdef DEBUG + write (iout,*) "Reading binary file, record",iii," ii",ii + call flush(iout) +#endif + read(icbase,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),& + ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),& + nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss),& + entfac(ii),rmstb(ii) +#ifdef DEBUG + write (iout,*) ii,iii,ij,entfac(ii) + write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres) + write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),& + i=nnt+nres,nct+nres) + write (iout,'(2e15.5)') entfac(ij) + write (iout,'(16i5)') nss_all(ij),(ihpb_all(i,ij),& + jhpb_all(i,ij),i=1,nss) + call flush(iout) +#endif + enddo + return + end subroutine daread_ccoords +!------------------------------------------------------------------------------ + subroutine dawrite_ccoords(istart_conf,iend_conf,unit_out) + +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" +#ifdef MPI + use MPI_data + include "mpif.h" +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.INTERACT" +! include "COMMON.IOUNITS" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.CLUSTER" + integer :: istart_conf,iend_conf + integer :: i,j,ii,ij,iii,unit_out + integer :: len + character(len=16) :: form,acc + character(len=32) :: nam +! +! Write conformations to a DA scratchfile. +! +#ifdef DEBUG + write (iout,*) "DAWRITE_COORDS" + write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf + write (iout,*) "lenrec",lenrec + inquire(unit=unit_out,name=nam,recl=len,form=form,access=acc) + write (iout,*) "len=",len," form=",form," acc=",acc + write (iout,*) "nam=",nam + call flush(iout) +#endif + do ii=istart_conf,iend_conf + iii=list_conf(ii) + ij = ii - istart_conf + 1 +#ifdef DEBUG + write (iout,*) "Writing binary file, record",iii," ii",ii + call flush(iout) +#endif + write(unit_out,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),& + ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),& + nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij)),& + entfac(ii),rmstb(ii) +#ifdef DEBUG + write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres) + write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),i=nnt+nres,& + nct+nres) + write (iout,'(2e15.5)') entfac(ij) + write (iout,'(16i5)') nss_all(ij),(ihpb(i,ij),jhpb(i,ij),i=1,& + nss_all(ij)) + call flush(iout) +#endif + enddo + return + end subroutine dawrite_ccoords +!----------------------------------------------------------------------------- +! readrtns.F +!----------------------------------------------------------------------------- + subroutine read_control +! +! Read molecular data +! + use energy_data, only: rescale_mode,distchainmax,ipot !,temp0 + use control_data, only: titel,outpdb,outmol2,refstr,pdbref,& + iscode,symetr,punch_dist,print_dist,nstart,nend,& + caonly,iopt,efree,lprint_cart,lprint_int +! implicit none +! include 'DIMENSIONS' +! include 'sizesclu.dat' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.CLUSTER' +! include 'COMMON.CHAIN' +! include 'COMMON.HEADER' +! include 'COMMON.FFIELD' +! include 'COMMON.FREE' +! include 'COMMON.INTERACT' + character(len=320) :: controlcard !,ucase +!#ifdef MPL +! include 'COMMON.INFO' +!#endif + integer :: i + + read (INP,'(a80)') titel + call card_concat(controlcard,.true.) + + call readi(controlcard,'NRES',nres,0) + +! call alloc_clust_arrays + allocate(rcutoff(max_cut+1)) !(max_cut+1) + allocate(beta_h(maxT)) !(maxT) + allocate(mult(nres)) !(maxres) + + + call readi(controlcard,'RESCALE',rescale_mode,2) + call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) + write (iout,*) "DISTCHAINMAX",distchainmax + call readi(controlcard,'PDBOUT',outpdb,0) + call readi(controlcard,'MOL2OUT',outmol2,0) + refstr=(index(controlcard,'REFSTR').gt.0) + write (iout,*) "REFSTR",refstr + pdbref=(index(controlcard,'PDBREF').gt.0) + iscode=index(controlcard,'ONE_LETTER') + tree=(index(controlcard,'MAKE_TREE').gt.0) + min_var=(index(controlcard,'MINVAR').gt.0) + plot_tree=(index(controlcard,'PLOT_TREE').gt.0) + punch_dist=(index(controlcard,'PUNCH_DIST').gt.0) + call readi(controlcard,'NCUT',ncut,1) + call readi(controlcard,'SYM',symetr,1) + write (iout,*) 'sym', symetr + call readi(controlcard,'NSTART',nstart,0) + call readi(controlcard,'NEND',nend,0) + call reada(controlcard,'ECUT',ecut,10.0d0) + call reada(controlcard,'PROB',prob_limit,0.99d0) + write (iout,*) "Probability limit",prob_limit + lgrp=(index(controlcard,'LGRP').gt.0) + caonly=(index(controlcard,'CA_ONLY').gt.0) + print_dist=(index(controlcard,'PRINT_DIST').gt.0) + call multreada(controlcard,'CUTOFF',rcutoff,ncut,-1.0d0) + call readi(controlcard,'IOPT',iopt,2) + lside = index(controlcard,"SIDE").gt.0 + efree = index(controlcard,"EFREE").gt.0 + call readi(controlcard,'NTEMP',nT,1) + write (iout,*) "nT",nT +!el call reada(controlcard,'TEMP0',temp0,300.0d0) !el + call multreada(controlcard,'TEMPER',beta_h,nT,300.0d0) + write (iout,*) "nT",nT + write (iout,*) 'beta_h',(beta_h(i),i=1,nT) + do i=1,nT + beta_h(i)=1.0d0/(1.987D-3*beta_h(i)) + enddo + write (iout,*) 'beta_h',(beta_h(i),i=1,nT) + lprint_cart=index(controlcard,"PRINT_CART") .gt.0 + lprint_int=index(controlcard,"PRINT_INT") .gt.0 + if (min_var) iopt=1 + return + end subroutine read_control +!----------------------------------------------------------------------------- + subroutine molread +! +! Read molecular data. +! + use geometry_data, only: nsup,cref,nres0,nstart_sup,nstart_seq,dc + use energy_data!, only: wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,& +! wang,wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,& +! wturn3,wturn4,wturn6,wvdwpp,weights + use control_data, only: titel,nstart,nend,pdbref,refstr,iscode,& + indpdb + use geometry, only: chainbuild,alloc_geo_arrays + use energy, only: alloc_ener_arrays + use control, only: rescode,setup_var,init_int_table + use conform_compar, only: contact +! implicit none +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.LOCAL' +! include 'COMMON.NAMES' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' +! include 'COMMON.CONTACTS' +! include 'COMMON.TIME1' +!#ifdef MPL +! include 'COMMON.INFO' +!#endif + character(len=4) :: sequence(nres) !(maxres) + character(len=800) :: weightcard +! integer rescode + real(kind=8) :: x(6*nres) !(maxvar) + integer :: itype_pdb(nres) !(maxres) +! logical seq_comp + integer :: i,j,kkk +! +! Body +! +!el allocate(weights(n_ene)) + allocate(weights(max_ene)) + call alloc_geo_arrays + call alloc_ener_arrays +!----------------------------- + allocate(c(3,2*nres+2)) !(3,maxres2+2) maxres2=2*maxres + allocate(dc(3,0:2*nres+2)) !(3,0:maxres2) + allocate(itype(nres+2)) !(maxres) + allocate(itel(nres+2)) + + do i=1,2*nres+2 + do j=1,3 + c(j,i)=0 + dc(j,i)=0 + enddo + enddo + do i=1,nres+2 + itype(i)=0 + itel(i)=0 + enddo +!-------------------------- +! Read weights of the subsequent energy terms. + call card_concat(weightcard,.true.) + call reada(weightcard,'WSC',wsc,1.0d0) + call reada(weightcard,'WLONG',wsc,wsc) + call reada(weightcard,'WSCP',wscp,1.0d0) + call reada(weightcard,'WELEC',welec,1.0D0) + call reada(weightcard,'WVDWPP',wvdwpp,welec) + call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) + call reada(weightcard,'WCORR4',wcorr4,0.0D0) + call reada(weightcard,'WCORR5',wcorr5,0.0D0) + call reada(weightcard,'WCORR6',wcorr6,0.0D0) + call reada(weightcard,'WTURN3',wturn3,1.0D0) + call reada(weightcard,'WTURN4',wturn4,1.0D0) + call reada(weightcard,'WTURN6',wturn6,1.0D0) + call reada(weightcard,'WSTRAIN',wstrain,1.0D0) + call reada(weightcard,'WSCCOR',wsccor,1.0D0) + call reada(weightcard,'WBOND',wbond,1.0D0) + call reada(weightcard,'WTOR',wtor,1.0D0) + call reada(weightcard,'WTORD',wtor_d,1.0D0) + call reada(weightcard,'WANG',wang,1.0D0) + call reada(weightcard,'WSCLOC',wscloc,1.0D0) + call reada(weightcard,'SCAL14',scal14,0.4D0) + call reada(weightcard,'SCALSCP',scalscp,1.0d0) + call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) + call reada(weightcard,'TEMP0',temp0,300.0d0) !!! el + if (index(weightcard,'SOFT').gt.0) ipot=6 +! 12/1/95 Added weight for the multi-body term WCORR + call reada(weightcard,'WCORRH',wcorr,1.0D0) + if (wcorr4.gt.0.0d0) wcorr=wcorr4 + weights(1)=wsc + weights(2)=wscp + weights(3)=welec + weights(4)=wcorr + weights(5)=wcorr5 + weights(6)=wcorr6 + weights(7)=wel_loc + weights(8)=wturn3 + weights(9)=wturn4 + weights(10)=wturn6 + weights(11)=wang + weights(12)=wscloc + weights(13)=wtor + weights(14)=wtor_d + weights(15)=wstrain + weights(16)=wvdwpp + weights(17)=wbond + weights(18)=scal14 +!el weights(19)=wsccor !!!!!!!!!!!!!!!! + weights(21)=wsccor + write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,& + wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wturn3,& + wturn4,wturn6,wsccor + 10 format (/'Energy-term weights (unscaled):'// & + 'WSCC= ',f10.6,' (SC-SC)'/ & + 'WSCP= ',f10.6,' (SC-p)'/ & + 'WELEC= ',f10.6,' (p-p electr)'/ & + 'WVDWPP= ',f10.6,' (p-p VDW)'/ & + 'WBOND= ',f10.6,' (stretching)'/ & + 'WANG= ',f10.6,' (bending)'/ & + 'WSCLOC= ',f10.6,' (SC local)'/ & + 'WTOR= ',f10.6,' (torsional)'/ & + 'WTORD= ',f10.6,' (double torsional)'/ & + 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & + 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ & + 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & + 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & + 'WCORR6= ',f10.6,' (multi-body 6th order)'/ & + 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & + 'WTURN4= ',f10.6,' (turns, 4th order)'/ & + 'WTURN6= ',f10.6,' (turns, 6th order)'/ & + 'WSCCOR= ',f10.6,' (SC-backbone torsinal correalations)') + + if (wcorr4.gt.0.0d0) then + write (iout,'(/2a/)') 'Local-electrostatic type correlation ',& + 'between contact pairs of peptide groups' + write (iout,'(2(a,f5.3/))') & + 'Cutoff on 4-6th order correlation terms: ',cutoff_corr,& + 'Range of quenching the correlation terms:',2*delt_corr + else if (wcorr.gt.0.0d0) then + write (iout,'(/2a/)') 'Hydrogen-bonding correlation ',& + 'between contact pairs of peptide groups' + endif + write (iout,'(a,f8.3)') & + 'Scaling factor of 1,4 SC-p interactions:',scal14 + write (iout,'(a,f8.3)') & + 'General scaling factor of SC-p interactions:',scalscp + r0_corr=cutoff_corr-delt_corr + do i=1,20 + aad(i,1)=scalscp*aad(i,1) + aad(i,2)=scalscp*aad(i,2) + bad(i,1)=scalscp*bad(i,1) + bad(i,2)=scalscp*bad(i,2) + enddo + + call flush(iout) + print *,'indpdb=',indpdb,' pdbref=',pdbref + +! Read sequence if not taken from the pdb file. + if (iscode.gt.0) then + read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) + else + read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) + endif +! Convert sequence to numeric code + do i=1,nres + itype(i)=rescode(i,sequence(i),iscode) + enddo + print *,nres + print '(20i4)',(itype(i),i=1,nres) + + do i=1,nres +#ifdef PROCOR + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then +#else + if (itype(i).eq.ntyp1) then +#endif + itel(i)=0 +#ifdef PROCOR + else if (iabs(itype(i+1)).ne.20) then +#else + else if (iabs(itype(i)).ne.20) then +#endif + itel(i)=1 + else + itel(i)=2 + endif + enddo + write (iout,*) "ITEL" + do i=1,nres-1 + write (iout,*) i,itype(i),itel(i) + enddo + + print *,'Call Read_Bridge.' + call read_bridge + nnt=1 + nct=nres + print *,'NNT=',NNT,' NCT=',NCT + if (itype(1).eq.ntyp1) nnt=2 + if (itype(nres).eq.ntyp1) nct=nct-1 + if (nstart.lt.nnt) nstart=nnt + if (nend.gt.nct .or. nend.eq.0) nend=nct + write (iout,*) "nstart",nstart," nend",nend + nres0=nres +! if (pdbref) then +! read(inp,'(a)') pdbfile +! write (iout,'(2a)') 'PDB data will be read from file ',pdbfile +! open(ipdbin,file=pdbfile,status='old',err=33) +! goto 34 +! 33 write (iout,'(a)') 'Error opening PDB file.' +! stop +! 34 continue +! print *,'Begin reading pdb data' +! call readpdb +! print *,'Finished reading pdb data' +! write (iout,'(a,i3,a,i3)')'nsup=',nsup,' nstart_sup=',nstart_sup +! do i=1,nres +! itype_pdb(i)=itype(i) +! enddo +! close (ipdbin) +! write (iout,'(a,i3)') 'nsup=',nsup +! nstart_seq=nnt +! if (nsup.le.(nct-nnt+1)) then +! do i=0,nct-nnt+1-nsup +! if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then +! nstart_seq=nnt+i +! goto 111 +! endif +! enddo +! write (iout,'(a)') +! & 'Error - sequences to be superposed do not match.' +! stop +! else +! do i=0,nsup-(nct-nnt+1) +! if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) +! & then +! nstart_sup=nstart_sup+i +! nsup=nct-nnt+1 +! goto 111 +! endif +! enddo +! write (iout,'(a)') +! & 'Error - sequences to be superposed do not match.' +! endif +! 111 continue +! write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, +! & ' nstart_seq=',nstart_seq +! endif +write(iout,*)"przed ini_int_tab" + call init_int_table +write(iout,*)"po ini_int_tab" +write(iout,*)"przed setup var" + call setup_var +write(iout,*)"po setup var" + write (iout,*) "molread: REFSTR",refstr + if (refstr) then + if (.not.pdbref) then + call read_angles(inp,*38) + goto 39 + 38 write (iout,'(a)') 'Error reading reference structure.' +#ifdef MPL + call mp_stopall(Error_Msg) +#else + stop 'Error reading reference structure' +#endif + 39 call chainbuild + nstart_sup=nnt + nstart_seq=nnt + nsup=nct-nnt+1 + kkk=1 + do i=1,2*nres + do j=1,3 + cref(j,i,kkk)=c(j,i) + enddo + enddo + endif + call contact(.true.,ncont_ref,icont_ref) + endif + return + end subroutine molread +!----------------------------------------------------------------------------- + subroutine openunits +! implicit none +! include 'DIMENSIONS' + use control_data, only: from_cx,from_bx,from_cart +#ifdef MPI + use MPI_data + include "mpif.h" + character(len=3) :: liczba +! include "COMMON.MPI" +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' + integer :: lenpre,lenpot !,ilen +! external ilen + character(len=16) :: cformat,cprint +! character(len=16) ucase + integer :: lenint,lenout + call getenv('INPUT',prefix) + call getenv('OUTPUT',prefout) + call getenv('INTIN',prefintin) + call getenv('COORD',cformat) + call getenv('PRINTCOOR',cprint) + call getenv('SCRATCHDIR',scratchdir) + from_bx=.true. + from_cx=.false. + if (index(ucase(cformat),'CX').gt.0) then + from_cx=.true. + from_bx=.false. + endif + from_cart=.true. + lenpre=ilen(prefix) + lenout=ilen(prefout) + lenint=ilen(prefintin) +! Get the names and open the input files + open (inp,file=prefix(:ilen(prefix))//'.inp',status='old') +#ifdef MPI + write (liczba,'(bz,i3.3)') me + outname=prefout(:lenout)//'_clust.out_'//liczba +#else + outname=prefout(:lenout)//'_clust.out' +#endif + if (from_bx) then + intinname=prefintin(:lenint)//'.bx' + else if (from_cx) then + intinname=prefintin(:lenint)//'.cx' + else + intinname=prefintin(:lenint)//'.int' + endif + rmsname=prefintin(:lenint)//'.rms' + open (jplot,file=prefout(:ilen(prefout))//'.tex',& + status='unknown') + open (jrms,file=rmsname,status='unknown') + open(iout,file=outname,status='unknown') +! Get parameter filenames and open the parameter files. + call getenv('BONDPAR',bondname) + open (ibond,file=bondname,status='old') + call getenv('THETPAR',thetname) + open (ithep,file=thetname,status='old') + call getenv('ROTPAR',rotname) + open (irotam,file=rotname,status='old') + call getenv('TORPAR',torname) + open (itorp,file=torname,status='old') + call getenv('TORDPAR',tordname) + open (itordp,file=tordname,status='old') + call getenv('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old') + call getenv('ELEPAR',elename) + open (ielep,file=elename,status='old') + call getenv('SIDEPAR',sidename) + open (isidep,file=sidename,status='old') + call getenv('SIDEP',sidepname) + open (isidep1,file=sidepname,status="old") + call getenv('SCCORPAR',sccorname) + open (isccor,file=sccorname,status="old") +#ifndef OLDSCP +! +! 8/9/01 In the newest version SCp interaction constants are read from a file +! Use -DOLDSCP to use hard-coded constants instead. +! + call getenv('SCPPAR',scpname) + open (iscpp,file=scpname,status='old') +#endif + return + end subroutine openunits +!----------------------------------------------------------------------------- +! geomout.F +!----------------------------------------------------------------------------- + subroutine pdboutC(etot,rmsd,tytul) + + use energy_data, only: ihpb,jhpb,itype +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' +! include 'COMMON.TEMPFAC' + character(len=50) :: tytul + character(len=1) :: chainid(10)=(/'A','B','C','D','E','F',& + 'G','H','I','J'/) + integer :: ica(nres) + real(kind=8) :: etot,rmsd + integer :: iatom,ichain,ires,i,j,iti + + write (ipdb,'(3a,1pe15.5,a,0pf7.2)') 'REMARK ',tytul(:20),& + ' ENERGY ',etot,' RMS ',rmsd + iatom=0 + ichain=1 + ires=0 + do i=nnt,nct + iti=itype(i) + if (iti.eq.ntyp1) then + ichain=ichain+1 + ires=0 + write (ipdb,'(a)') 'TER' + else + ires=ires+1 + iatom=iatom+1 + ica(i)=iatom + write (ipdb,10) iatom,restyp(iti),chainid(ichain),& + ires,(c(j,i),j=1,3),1.0d0,tempfac(1,i) + if (iti.ne.10) then + iatom=iatom+1 + write (ipdb,20) iatom,restyp(iti),chainid(ichain),& + ires,(c(j,nres+i),j=1,3),1.0d0,tempfac(2,i) + endif + endif + enddo + write (ipdb,'(a)') 'TER' + do i=nnt,nct-1 + if (itype(i).eq.ntyp1) cycle + if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then + write (ipdb,30) ica(i),ica(i+1) + else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then + write (ipdb,30) ica(i),ica(i+1),ica(i)+1 + else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then + write (ipdb,30) ica(i),ica(i)+1 + endif + enddo + if (itype(nct).ne.10) then + write (ipdb,30) ica(nct),ica(nct)+1 + endif + do i=1,nss + write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 + enddo + write (ipdb,'(a6)') 'ENDMDL' + 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,2f6.2) + 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,2f6.2) + 30 FORMAT ('CONECT',8I5) + return + end subroutine pdboutC +!----------------------------------------------------------------------------- + subroutine cartout(igr,i,etot,free,rmsd,plik) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'sizesclu.dat' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.CLUSTER' + integer :: igr,i,j,k + real(kind=8) :: etot,free,rmsd + character(len=80) :: plik + open (igeom,file=plik,position='append') + write (igeom,'(2e15.5,f10.5,$)') etot,free,rmsd + write (igeom,'(i4,$)') & + nss_all(i),(ihpb_all(j,i),jhpb_all(j,i),j=1,nss_all(i)) + write (igeom,'(i10)') iscore(i) + write (igeom,'(8f10.5)') & + ((allcart(k,j,i),k=1,3),j=1,nres),& + ((allcart(k,j+nres,i),k=1,3),j=nnt,nct) + return + end subroutine cartout +!------------------------------------------------------------------------------ +! subroutine alloc_clust_arrays(n_conf) + +! integer :: n_conf +!COMMON.CLUSTER +! common /clu/ +! allocate(diss(maxdist)) !(maxdist) +!el allocate(energy(0:maxconf),totfree(0:maxconf)) !(0:maxconf) +! allocatable :: enetb !(max_ene,maxstr_proc) +!el allocate(entfac(maxconf)) !(maxconf) +! allocatable :: totfree_gr !(maxgr) +!el allocate(rcutoff(max_cut+1)) !(max_cut+1) +! common /clu1/ +! allocatable :: licz,iass !(maxgr) +! allocatable :: nconf !(maxgr,maxingr) +! allocatable :: iass_tot !(maxgr,max_cut) +! allocatable :: list_conf !(maxconf) +! common /alles/ +!el allocatable :: allcart !(3,maxres2,maxstr_proc) +!el allocate(rmstb(maxconf)) !(maxconf) +!el allocate(mult(nres)) !(maxres) +!el allocatable :: nss_all !(maxstr_proc) +!el allocatable :: ihpb_all,jhpb_all !(maxss,maxstr_proc) +! allocate(icc(n_conf),iscore(n_conf)) !(maxconf) +!COMMON.TEMPFAC +! common /factemp/ +! allocatable :: tempfac !(2,maxres) +!COMMON.FREE +! common /free/ +!el allocate(beta_h(maxT)) !(maxT) + +! end subroutine alloc_clust_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module io_clust diff --git a/source/cluster/io_clust.f90 b/source/cluster/io_clust.f90 deleted file mode 100644 index db74bf6..0000000 --- a/source/cluster/io_clust.f90 +++ /dev/null @@ -1,1824 +0,0 @@ - module io_clust -!----------------------------------------------------------------------------- - use clust_data - use io_units -! use names - use io_base !, only: ilen - use geometry_data, only: nres,c - use energy_data, only: nnt,nct,nss - use control_data, only: lside - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! wrtclust.f -!----------------------------------------------------------------------------- - SUBROUTINE WRTCLUST(NCON,ICUT,PRINTANG,PRINTPDB,printmol2,ib) - - use hc_, only: ioffset - use control_data, only: lprint_cart,lprint_int,titel - use geometry, only: int_from_cart1,nres -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'sizesclu.dat' - integer,parameter :: num_in_line=5 - LOGICAL :: PRINTANG(max_cut) - integer :: PRINTPDB(max_cut),printmol2(max_cut) -! include 'COMMON.CONTROL' -! include 'COMMON.HEADER' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.CLUSTER' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.FREE' -! include 'COMMON.TEMPFAC' - real(kind=8) :: rmsave(maxgr) - CHARACTER(len=64) :: prefixp,NUMM,MUMM,EXTEN,extmol - character(len=80) :: cfname - character(len=8) :: ctemper - DATA EXTEN /'.pdb'/,extmol /'.mol2'/,NUMM /'000'/,& - MUMM /'000'/ -! external ilen - integer :: ncon,icut,ib - integer :: i,ii,ii1,ii2,igr,ind1,ind2,ico,icon,& - irecord,nrecord,j,k,jj,ind,ncon_lim,ncon_out - real(kind=8) :: temper,curr_dist,emin,qpart,boltz,& - ave_dim,amax_dim,emin1 - - - allocate(tempfac(2,nres)) - - do i=1,64 - cfname(i:i)=" " - enddo -! print *,"calling WRTCLUST",ncon -! write (iout,*) "ICUT",icut," PRINTPDB ",PRINTPDB(icut) - rewind 80 - call flush(iout) - temper=1.0d0/(beta_h(ib)*1.987d-3) - if (temper.lt.100.0d0) then - write(ctemper,'(f3.0)') temper - ctemper(3:3)=" " - else if (temper.lt.1000.0) then - write (ctemper,'(f4.0)') temper - ctemper(4:4)=" " - else - write (ctemper,'(f5.0)') temper - ctemper(5:5)=" " - endif - - do i=1,ncon*(ncon-1)/2 - read (80) diss(i) - enddo - close(80,status='delete') -! -! PRINT OUT THE RESULTS OF CLUSTER ANALYSIS -! - ii1= index(intinname,'/') - ii2=ii1 - ii1=ii1+1 - do while (ii2.gt.0) - ii1=ii1+ii2 - ii2=index(intinname(ii1:),'/') - enddo - ii = ii1+index(intinname(ii1:),'.')-1 - if (ii.eq.0) then - ii=ilen(intinname) - else - ii=ii-1 - endif - prefixp=intinname(ii1:ii) -!d print *,icut,printang(icut),printpdb(icut),printmol2(icut) -!d print *,'ecut=',ecut - WRITE (iout,100) NGR - DO 19 IGR=1,NGR - WRITE (iout,200) IGR,totfree_gr(igr)/beta_h(ib),LICZ(IGR) - NRECORD=LICZ(IGR)/num_in_line - IND1=1 - DO 63 IRECORD=1,NRECORD - IND2=IND1+num_in_line-1 - WRITE (iout,300) (list_conf(NCONF(IGR,ICO)),& - totfree(NCONF(IGR,ICO))/beta_h(ib),ICO=IND1,IND2) - IND1=IND2+1 - 63 CONTINUE - WRITE (iout,300) (list_conf(NCONF(IGR,ICO)),& - totfree(NCONF(IGR,ICO))/beta_h(ib),ICO=IND1,LICZ(IGR)) - IND1=1 - ICON=list_conf(NCONF(IGR,1)) -! WRITE (iout,'(16F5.0)') (rad2deg*phiall(IND,icon),IND=4,nphi+3) -! 12/8/93 Estimation of "diameters" of the subsequent families. - ave_dim=0.0 - amax_dim=0.0 -! write (iout,*) "ecut",ecut - do i=2,licz(igr) - ii=nconf(igr,i) - if (totfree(ii)-emin .gt. ecut) goto 10 - do j=1,i-1 - jj=nconf(igr,j) - if (jj.eq.1) exit - if (ii.lt.jj) then - ind=ioffset(ncon,ii,jj) - else - ind=ioffset(ncon,jj,ii) - endif -! write (iout,*) " ncon",ncon,"i",i," j",j," ii",ii," jj",jj, -! & " ind",ind - call flush(iout) - curr_dist=dabs(diss(ind)+0.0d0) -! write(iout,'(i10,4i4,f12.4)') ind,ii,jj,list_conf(ii), -! & list_conf(jj),curr_dist - if (curr_dist .gt. amax_dim) amax_dim=curr_dist - ave_dim=ave_dim+curr_dist**2 - enddo - enddo - 10 if (licz(igr) .gt. 1) & - ave_dim=sqrt(ave_dim/(licz(igr)*(licz(igr)-1)/2)) - write (iout,'(/A,F8.1,A,F8.1)') & - 'Max. distance in the family:',amax_dim,& - '; average distance in the family:',ave_dim - rmsave(igr)=0.0d0 - qpart=0.0d0 - do i=1,licz(igr) - icon=nconf(igr,i) - boltz=dexp(-totfree(icon)) - rmsave(igr)=rmsave(igr)+boltz*rmstb(icon) - qpart=qpart+boltz - enddo - rmsave(igr)=rmsave(igr)/qpart - write (iout,'(a,f5.2,a)') "Average RMSD",rmsave(igr)," A" - 19 CONTINUE - WRITE (iout,400) - WRITE (iout,500) (list_conf(I),IASS(I),I=1,NCON) -! print *,icut,printang(icut) - IF (PRINTANG(ICUT) .and. (lprint_cart .or. lprint_int)) then - emin=totfree_gr(1) -! print *,'emin',emin,' ngr',ngr - if (lprint_cart) then - cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& - //"K"//".x" - else - cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& - //"K"//".int" - endif - do igr=1,ngr - icon=nconf(igr,1) - if (totfree_gr(igr)-emin.le.ecut) then - if (lprint_cart) then - call cartout(igr,icon,totfree(icon)/beta_h(ib),& - totfree_gr(igr)/beta_h(ib),& - rmstb(icon),cfname) - else -! print '(a)','calling briefout' - do i=1,2*nres - do j=1,3 - c(j,i)=allcart(j,i,icon) - enddo - enddo - call int_from_cart1(.false.) -!el call briefout(igr,iscore(icon),totfree(icon)/beta_h(ib),& -!el totfree_gr(igr),nss_all(icon),ihpb_all(1,icon),& -!el jhpb_all(1,icon),cfname) - call briefout(igr,totfree(icon)/beta_h(ib),& - totfree_gr(igr)) -! print '(a)','exit briefout' - endif - endif - enddo - close(igeom) - ENDIF - IF (PRINTPDB(ICUT).gt.0) THEN -! Write out a number of conformations from each family in PDB format and -! create InsightII command file for their displaying in different colors - cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& - //"K_"//'ave'//exten - write (iout,*) "cfname",cfname - OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') - write (ipdb,'(a,f8.2)') & - "REMAR AVERAGE CONFORMATIONS AT TEMPERATURE",temper - close (ipdb) - I=1 - ICON=NCONF(1,1) - EMIN=totfree_gr(I) - emin1=totfree(icon) - DO WHILE(I.LE.NGR .AND. totfree_gr(i)-EMIN.LE.ECUT) -! write (iout,*) "i",i," ngr",ngr,totfree_gr(I),EMIN,ecut - write (NUMM,'(bz,i4.4)') i - ncon_lim=min0(licz(i),printpdb(icut)) - cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& - //"K_"//numm(:ilen(numm))//exten - OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') - write (ipdb,'("REMARK CLUSTER",i5," FREE ENERGY",1pe14.5," AVE RMSD",0pf5.2)')& - i,totfree_gr(i)/beta_h(ib),rmsave(i) !' -! Write conformations of the family i to PDB files - ncon_out=1 - do while (ncon_out.lt.printpdb(icut) .and. & - ncon_out.lt.licz(i).and. & - totfree(nconf(i,ncon_out+1))-EMIN1.LE.ECUT) - ncon_out=ncon_out+1 -! write (iout,*) i,ncon_out,nconf(i,ncon_out), -! & totfree(nconf(i,ncon_out)),emin1,ecut - enddo - write (iout,*) "ncon_out",ncon_out - call flush(iout) - do j=1,nres - tempfac(1,j)=5.0d0 - tempfac(2,j)=5.0d0 - enddo - do j=1,ncon_out - icon=nconf(i,j) - do ii=1,2*nres - do k=1,3 - c(k,ii)=allcart(k,ii,icon) - enddo - enddo - call pdboutC(totfree(icon)/beta_h(ib),rmstb(icon),titel) - write (ipdb,'("TER")') - enddo - close(ipdb) -! Average structures and structures closest to average - cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& - //"K_"//'ave'//exten - OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED',& - position="APPEND") - call ave_coord(i) - write (ipdb,'(a,i5)') "REMARK CLUSTER",i - call pdboutC(totfree_gr(i)/beta_h(ib),rmsave(i),titel) - write (ipdb,'("TER")') - call closest_coord(i) - call pdboutC(totfree_gr(i)/beta_h(ib),rmsave(i),titel) - write (ipdb,'("TER")') - close (ipdb) - I=I+1 - ICON=NCONF(I,1) - emin1=totfree(icon) - ENDDO - ENDIF - IF (printmol2(icut).gt.0) THEN -! Write out a number of conformations from each family in PDB format and -! create InsightII command file for their displaying in different colors - I=1 - ICON=NCONF(1,1) - EMIN=ENERGY(ICON) - emin1=emin - DO WHILE(I.LE.NGR .AND. totfree_gr(i)-EMIN.LE.ECUT) - write (NUMM,'(bz,i4.4)') i - cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))& - //"K_"//numm(:ilen(numm))//extmol - OPEN(imol2,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') - ncon_out=1 - do while (ncon_out.lt.printmol2(icut) .and. & - ncon_out.lt.licz(i).and. & - totfree(nconf(i,ncon_out+1))-EMIN1.LE.ECUT) - ncon_out=ncon_out+1 - enddo - do j=1,ncon_out - icon=nconf(i,j) - do ii=1,2*nres - do k=1,3 - c(k,ii)=allcart(k,ii,icon) - enddo - enddo - CALL MOL2OUT(totfree(icon)/beta_h(ib),'STRUCTURE'//numm) - enddo - CLOSE(imol2) - I=I+1 - ICON=NCONF(I,1) - emin1=totfree(icon) - ENDDO - ENDIF - 100 FORMAT (//'THERE ARE ',I4,' FAMILIES OF CONFORMATIONS') - 200 FORMAT (/'FAMILY ',I4,' WITH TOTAL FREE ENERGY',1pE15.5,& - ' CONTAINS ',I4,' CONFORMATION(S): ') -! 300 FORMAT ( 8(I4,F6.1)) - 300 FORMAT (5(I4,1pe12.3)) - 400 FORMAT (//'ASSIGNMENT OF CONSECUTIVE CONFORMATIONS TO FAMILIES:') - 500 FORMAT (8(2I4,2X)) - 600 FORMAT ('REMARK FAMILY',I4,' CONFORMATION',I4,' ENERGY ',E15.6) - RETURN - END SUBROUTINE WRTCLUST -!------------------------------------------------------------------------------ - subroutine ave_coord(igr) - - use control_data, only:lside - use regularize_, only:fitsq,matvec -! implicit none -! include 'DIMENSIONS' -! include 'sizesclu.dat' -! include 'COMMON.CONTROL' -! include 'COMMON.CLUSTER' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.TEMPFAC' -! include 'COMMON.IOUNITS' - logical :: non_conv - real(kind=8) :: przes(3),obrot(3,3) - real(kind=8) :: xx(3,2*nres),yy(3,2*nres),csq(3,2*nres) !(3,maxres2) - real(kind=8) :: eref - integer :: i,ii,j,k,icon,jcon,igr - real(kind=8) :: rms,boltz,qpart,cwork(3,2*nres),cref1(3,2*nres) !(3,maxres2) -! write (iout,*) "AVE_COORD: igr",igr - jcon=nconf(igr,1) - eref=totfree(jcon) - boltz = dexp(-totfree(jcon)+eref) - qpart=boltz - do i=1,2*nres - do j=1,3 - c(j,i)=allcart(j,i,jcon)*boltz - cref1(j,i)=allcart(j,i,jcon) - csq(j,i)=allcart(j,i,jcon)**2*boltz - enddo - enddo - DO K=2,LICZ(IGR) - jcon=nconf(igr,k) - if (lside) then - ii=0 - do i=nnt,nct - ii=ii+1 - do j=1,3 - xx(j,ii)=allcart(j,i,jcon) - yy(j,ii)=cref1(j,i) - enddo - enddo - do i=nnt,nct -! if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - xx(j,ii)=allcart(j,i+nres,jcon) - yy(j,ii)=cref1(j,i+nres) - enddo -! endif - enddo - call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) - else - do i=nnt,nct - do j=1,3 - cwork(j,i)=allcart(j,i,jcon) - enddo - enddo - call fitsq(rms,cwork(1,nnt),cref1(1,nnt),nct-nnt+1,przes,obrot & - ,non_conv) - endif -! write (iout,*) "rms",rms -! do i=1,3 -! write (iout,'(i3,f10.5,5x,3f10.5)')i,przes(i),(obrot(i,j),j=1,3) -! enddo - if (rms.lt.0.0) then - print *,'error, rms^2 = ',rms,icon,jcon - stop - endif - if (non_conv) print *,non_conv,icon,jcon - boltz=dexp(-totfree(jcon)+eref) - qpart = qpart + boltz - do i=1,2*nres - do j=1,3 - xx(j,i)=allcart(j,i,jcon) - enddo - enddo - call matvec(cwork,obrot,xx,2*nres) - do i=1,2*nres -! write (iout,'(i5,2(3f10.5,5x))') i,(cwork(j,i),j=1,3), -! & (allcart(j,i,jcon),j=1,3) - do j=1,3 - cwork(j,i)=cwork(j,i)+przes(j) - c(j,i)=c(j,i)+cwork(j,i)*boltz - csq(j,i)=csq(j,i)+cwork(j,i)**2*boltz - enddo - enddo - ENDDO ! K - do i=1,2*nres - do j=1,3 - c(j,i)=c(j,i)/qpart - csq(j,i)=csq(j,i)/qpart-c(j,i)**2 - enddo -! write (iout,'(i5,3f10.5)') i,(csq(j,i),j=1,3) - enddo - do i=nnt,nct - tempfac(1,i)=0.0d0 - tempfac(2,i)=0.0d0 - do j=1,3 - tempfac(1,i)=tempfac(1,i)+csq(j,i) - tempfac(2,i)=tempfac(2,i)+csq(j,i+nres) - enddo - tempfac(1,i)=dsqrt(tempfac(1,i)) - tempfac(2,i)=dsqrt(tempfac(2,i)) - enddo - return - end subroutine ave_coord -!------------------------------------------------------------------------------ - subroutine closest_coord(igr) - - use regularize_, only:fitsq -! implicit none -! include 'DIMENSIONS' -! include 'sizesclu.dat' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -! include 'COMMON.CLUSTER' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' - logical :: non_conv - real(kind=8) :: przes(3),obrot(3,3) - real(kind=8) :: xx(3,2*nres),yy(3,2*nres) !(3,maxres2) - integer :: i,ii,j,k,icon,jcon,jconmin,igr - real(kind=8) :: rms,rmsmin,cwork(3,2*nres) - rmsmin=1.0d10 - jconmin=nconf(igr,1) - DO K=1,LICZ(IGR) - jcon=nconf(igr,k) - if (lside) then - ii=0 - do i=nnt,nct - ii=ii+1 - do j=1,3 - xx(j,ii)=allcart(j,i,jcon) - yy(j,ii)=c(j,i) - enddo - enddo - do i=nnt,nct -! if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - xx(j,ii)=allcart(j,i+nres,jcon) - yy(j,ii)=c(j,i+nres) - enddo -! endif - enddo - call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) - else - do i=nnt,nct - do j=1,3 - cwork(j,i)=allcart(j,i,jcon) - enddo - enddo - call fitsq(rms,cwork(1,nnt),c(1,nnt),nct-nnt+1,przes,obrot,& - non_conv) - endif - if (rms.lt.0.0) then - print *,'error, rms^2 = ',rms,icon,jcon - stop - endif -! write (iout,*) "jcon",jcon," rms",rms," rmsmin",rmsmin - if (non_conv) print *,non_conv,icon,jcon - if (rms.lt.rmsmin) then - rmsmin=rms - jconmin=jcon - endif - ENDDO ! K -! write (iout,*) "rmsmin",rmsmin," rms",rms - call flush(iout) - do i=1,2*nres - do j=1,3 - c(j,i)=allcart(j,i,jconmin) - enddo - enddo - return - end subroutine closest_coord -!----------------------------------------------------------------------------- -! read_coords.F -!----------------------------------------------------------------------------- - subroutine read_coords(ncon,*) - - use energy_data, only: ihpb,jhpb,max_ene - use control_data, only: from_bx,from_cx - use control, only: tcpu -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" -#ifdef MPI - use MPI_data - include "mpif.h" - integer :: IERROR,ERRCODE !,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#else - use MPI_data, only: nprocs -#endif -! include "COMMON.CONTROL" -! include "COMMON.CHAIN" -! include "COMMON.INTERACT" -! include "COMMON.IOUNITS" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.CLUSTER" - character(len=3) :: liczba - integer :: ncon - integer :: i,j,jj,jjj,jj_old,icount,k,kk,l,ii,if,ib,& - nn,nn1,inan - integer :: ixdrf,iret,itmp - real(kind=4) :: prec,reini,refree,rmsdev - integer :: nrec,nlines,iscor,lenrec,lenrec_in - real(kind=8) :: energ,t_acq !,tcpu -!el integer ilen,iroof -!el external ilen,iroof - real(kind=8) :: rjunk - integer :: ntot_all(0:nprocs-1) !(0:maxprocs-1) - logical :: lerr - real(kind=8) :: energia(0:max_ene),etot - real(kind=4) :: csingle(3,2*nres+2) - integer :: Previous,Next - character(len=256) :: bprotfiles -! print *,"Processor",me," calls read_protein_data" -#ifdef MPI - if (me.eq.master) then - Previous=MPI_PROC_NULL - else - Previous=me-1 - endif - if (me.eq.nprocs-1) then - Next=MPI_PROC_NULL - else - Next=me+1 - endif -! Set the scratchfile names - write (liczba,'(bz,i3.3)') me - - allocate(STATUS(MPI_STATUS_SIZE)) -#endif -! 1/27/05 AL Change stored coordinates to single precision and don't store -! energy components in the binary databases. - lenrec=12*(nres+nct-nnt+1)+4*(2*nss+2)+16 - lenrec_in=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 -#ifdef DEBUG - write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss", nss - write (iout,*) "lenrec_in",lenrec_in -#endif - bprotfiles=scratchdir(:ilen(scratchdir))// & - "/"//prefix(:ilen(prefix))//liczba//".xbin" -! EL -! allocate cluster arrays - allocate(energy(0:maxconf),totfree(0:maxconf)) !(0:maxconf) - allocate(entfac(maxconf)) !(maxconf) - allocate(rmstb(maxconf)) !(maxconf) - allocate(allcart(3,2*nres,maxstr_proc)) !(3,maxres2,maxstr_proc) - allocate(nss_all(maxstr_proc)) !(maxstr_proc) - allocate(ihpb_all(maxss,maxstr_proc),jhpb_all(maxss,maxstr_proc))!(maxss,maxstr_proc) - allocate(iscore(maxconf)) !(maxconf) - - -#ifdef CHUJ - ICON=1 - 123 continue - if (from_cart .and. .not. from_bx .and. .not. from_cx) then - if (efree) then - read (intin,*,end=13,err=11) energy(icon),totfree(icon),& - rmstb(icon),& - nss_all(icon),(ihpb_all(ii,icon),jhpb_all(i,icon),& - i=1,nss_all(icon)),iscore(icon) - else - read (intin,*,end=13,err=11) energy(icon),rmstb(icon),& - nss_all(icon),(ihpb_all(ii,icon),jhpb_all(i,icon),& - i=1,nss_all(icon)),iscore(icon) - endif - read (intin,'(8f10.5)',end=13,err=10) & - ((allcart(j,i,icon),j=1,3),i=1,nres),& - ((allcart(j,i+nres,icon),j=1,3),i=nnt,nct) - print *,icon,energy(icon),nss_all(icon),rmstb(icon) - else - read(intin,'(a80)',end=13,err=12) lineh - read(lineh(:5),*,err=8) ic - if (efree) then - read(lineh(6:),*,err=8) energy(icon) - else - read(lineh(6:),*,err=8) energy(icon) - endif - goto 9 - 8 ic=1 - print *,'error, assuming e=1d10',lineh - energy(icon)=1d10 - nss=0 - 9 continue -!old read(lineh(18:),*,end=13,err=11) nss_all(icon) - ii = index(lineh(15:)," ")+15 - read(lineh(ii:),*,end=13,err=11) nss_all(icon) - IF (NSS_all(icon).LT.9) THEN - read (lineh(20:),*,end=102) & - (IHPB_all(I,icon),JHPB_all(I,icon),I=1,NSS_all(icon)),& - iscore(icon) - ELSE - read (lineh(20:),*,end=102) & - (IHPB_all(I,icon),JHPB_all(I,icon),I=1,8) - read (intin,*) (IHPB_all(I,icon),JHPB_all(I,icon),& - I=9,NSS_all(icon)),iscore(icon) - ENDIF - - 102 continue - - PRINT *,'IC:',IC,' ENERGY:',ENERGY(ICON) - call read_angles(intin,*13) - do i=1,nres - phiall(i,icon)=phi(i) - thetall(i,icon)=theta(i) - alphall(i,icon)=alph(i) - omall(i,icon)=omeg(i) - enddo - endif - ICON=ICON+1 - GOTO 123 -! -! CALCULATE DISTANCES -! - 10 print *,'something wrong with angles' - goto 13 - 11 print *,'something wrong with NSS',nss - goto 13 - 12 print *,'something wrong with header' - - 13 NCON=ICON-1 - -#endif - call flush(iout) - jj_old=1 - open (icbase,file=bprotfiles,status="unknown",& - form="unformatted",access="direct",recl=lenrec) -! Read conformations from binary DA files (one per batch) and write them to -! a binary DA scratchfile. - jj=0 - jjj=0 -#ifdef MPI - write (liczba,'(bz,i3.3)') me - IF (ME.EQ.MASTER) THEN -! Only the master reads the database; it'll send it to the other procs -! through a ring. -#endif - t_acq = tcpu() - icount=0 - - if (from_bx) then - - open (intin,file=intinname,status="old",form="unformatted",& - access="direct",recl=lenrec_in) - - else if (from_cx) then -#if (defined(AIX) && !defined(JUBL)) - call xdrfopen_(ixdrf,intinname, "r", iret) -#else - call xdrfopen(ixdrf,intinname, "r", iret) -#endif - prec=10000.0 - write (iout,*) "xdrfopen: iret",iret - if (iret.eq.0) then - write (iout,*) "Error: coordinate file ",& - intinname(:ilen(intinname))," does not exist." - call flush(iout) -#ifdef MPI - call MPI_ABORT(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop - endif - else - write (iout,*) "Error: coordinate format not specified" - call flush(iout) -#ifdef MPI - call MPI_ABORT(MPI_COMM_WORLD,IERROR,ERRCODE) -#else - stop -#endif - endif - -!#define DEBUG -#ifdef DEBUG - write (iout,*) "Opening file ",intinname(:ilen(intinname)) - write (iout,*) "lenrec",lenrec_in - call flush(iout) -#endif -!#undef DEBUG -! write (iout,*) "maxconf",maxconf - i=0 - do while (.true.) - i=i+1 -!el if (i.gt.maxconf) then -!el write (iout,*) "Error: too many conformations ",& -!el "(",maxconf,") maximum." -!#ifdef MPI -!el call MPI_Abort(MPI_COMM_WORLD,errcode,ierror) -!#endif -!el stop -!el endif -! write (iout,*) "i",i -! call flush(iout) - if (from_bx) then - read(intin,err=101,end=101) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - energy(jj+1),& - entfac(jj+1),rmstb(jj+1),iscor - do j=1,2*nres - do k=1,3 - c(k,j)=csingle(k,j) - enddo - enddo - else -#if (defined(AIX) && !defined(JUBL)) - call xdrf3dfcoord_(ixdrf, csingle, itmp, prec, iret) - if (iret.eq.0) goto 101 - call xdrfint_(ixdrf, nss, iret) - if (iret.eq.0) goto 101 - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - if (iret.eq.0) goto 101 - call xdrfint_(ixdrf, jhpb(j), iret) - if (iret.eq.0) goto 101 - enddo - call xdrffloat_(ixdrf,reini,iret) - if (iret.eq.0) goto 101 - call xdrffloat_(ixdrf,refree,iret) - if (iret.eq.0) goto 101 - call xdrffloat_(ixdrf,rmsdev,iret) - if (iret.eq.0) goto 101 - call xdrfint_(ixdrf,iscor,iret) - if (iret.eq.0) goto 101 -#else -! write (iout,*) "calling xdrf3dfcoord" - call xdrf3dfcoord(ixdrf, csingle, itmp, prec, iret) -! write (iout,*) "iret",iret -! call flush(iout) - if (iret.eq.0) goto 101 - call xdrfint(ixdrf, nss, iret) -! write (iout,*) "iret",iret -! write (iout,*) "nss",nss - call flush(iout) - if (iret.eq.0) goto 101 - do k=1,nss - call xdrfint(ixdrf, ihpb(k), iret) - if (iret.eq.0) goto 101 - call xdrfint(ixdrf, jhpb(k), iret) - if (iret.eq.0) goto 101 - enddo - call xdrffloat(ixdrf,reini,iret) - if (iret.eq.0) goto 101 - call xdrffloat(ixdrf,refree,iret) - if (iret.eq.0) goto 101 - call xdrffloat(ixdrf,rmsdev,iret) - if (iret.eq.0) goto 101 - call xdrfint(ixdrf,iscor,iret) - if (iret.eq.0) goto 101 -#endif - energy(jj+1)=reini - entfac(jj+1)=refree - rmstb(jj+1)=rmsdev - do k=1,nres - do l=1,3 - c(l,k)=csingle(l,k) - enddo - enddo - do k=nnt,nct - do l=1,3 - c(l,nres+k)=csingle(l,nres+k-nnt+1) - enddo - enddo - endif -#ifdef DEBUG - write (iout,'(5hREAD ,i5,3f15.4,i10)') & - jj+1,energy(jj+1),entfac(jj+1),& - rmstb(jj+1),iscor - write (iout,*) "Conformation",jjj+1,jj+1 - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - call flush(iout) -#endif - call add_new_cconf(jjj,jj,jj_old,icount,Next) - enddo - 101 continue - write (iout,*) i-1," conformations read from DA file ",& - intinname(:ilen(intinname)) - write (iout,*) jj," conformations read so far" - if (from_bx) then - close(intin) - else -#if (defined(AIX) && !defined(JUBL)) - call xdrfclose_(ixdrf, iret) -#else - call xdrfclose(ixdrf, iret) -#endif - endif -#ifdef MPI -!#ifdef DEBUG - write (iout,*) "jj_old",jj_old," jj",jj -!#endif - call write_and_send_cconf(icount,jj_old,jj,Next) - call MPI_Send(0,1,MPI_INTEGER,Next,570,& - MPI_COMM_WORLD,IERROR) - jj_old=jj+1 -#else - call write_and_send_cconf(icount,jj_old,jj,Next) -#endif - t_acq = tcpu() - t_acq -#ifdef MPI - write (iout,*) "Processor",me,& - " time for conformation read/send",t_acq - ELSE -! A worker gets the confs from the master and sends them to its neighbor - t_acq = tcpu() - call receive_and_pass_cconf(icount,jj_old,jj,& - Previous,Next) - t_acq = tcpu() - t_acq - ENDIF -#endif - ncon=jj -! close(icbase) - close(intin) - - write(iout,*)"A total of",ncon," conformations read." - - allocate(enetb(1:max_ene,ncon)) !(max_ene,maxstr_proc) -#ifdef MPI -! Check if everyone has the same number of conformations - call MPI_Allgather(ncon,1,MPI_INTEGER,& - ntot_all(0),1,MPI_INTEGER,MPI_Comm_World,IERROR) - lerr=.false. - do i=0,nprocs-1 - if (i.ne.me) then - if (ncon.ne.ntot_all(i)) then - write (iout,*) "Number of conformations at processor",i,& - " differs from that at processor",me,& - ncon,ntot_all(i) - lerr = .true. - endif - endif - enddo - if (lerr) then - write (iout,*) - write (iout,*) "Number of conformations read by processors" - write (iout,*) - do i=0,nprocs-1 - write (iout,'(8i10)') i,ntot_all(i) - enddo - write (iout,*) "Calculation terminated." - call flush(iout) - return 1 - endif - return -#endif - 1111 write(iout,*) "Error opening coordinate file ",& - intinname(:ilen(intinname)) - call flush(iout) - return 1 - end subroutine read_coords -!------------------------------------------------------------------------------ - subroutine add_new_cconf(jjj,jj,jj_old,icount,Next) - - use geometry_data, only: vbld,rad2deg,theta,phi,alph,omeg,deg2rad - use energy_data, only: itel,itype,dsc,max_ene - use control_data, only: symetr - use geometry, only: int_from_cart1 -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" -! include "COMMON.CLUSTER" -! include "COMMON.CONTROL" -! include "COMMON.CHAIN" -! include "COMMON.INTERACT" -! include "COMMON.LOCAL" -! include "COMMON.IOUNITS" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" - integer :: i,j,jj,jjj,jj_old,icount,k,kk,l,ii,ib,& - nn,nn1,inan,Next,itj,chalen - real(kind=8) :: etot,energia(0:max_ene) - jjj=jjj+1 - chalen=int((nct-nnt+2)/symetr) - call int_from_cart1(.false.) - do j=nnt+1,nct - if (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0) then - if (j.gt.2) then - if (itel(j).ne.0 .and. itel(j-1).ne.0) then - write (iout,*) "Conformation",jjj,jj+1 - write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),itel(j),& - chalen - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,*) & - "This conformation WILL NOT be added to the database." - return - endif - endif - endif - enddo - do j=nnt,nct - itj=itype(j) - if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(iabs(itj))) & - .gt.2.0d0) then - write (iout,*) "Conformation",jjj,jj+1 - write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j) - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,*) & - "This conformation WILL NOT be added to the database." - return - endif - enddo - do j=3,nres - if (theta(j).le.0.0d0) then - write (iout,*) & - "Zero theta angle(s) in conformation",jjj,jj+1 - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,*) & - "This conformation WILL NOT be added to the database." - return - endif - if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad - enddo - jj=jj+1 -#ifdef DEBUG - write (iout,*) "Conformation",jjj,jj - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (vbld(k+nres),k=nnt,nct) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) - write (iout,'(e15.5,16i5)') entfac(icount+1) -! & iscore(icount+1,0) -#endif - icount=icount+1 - call store_cconf_from_file(jj,icount) - if (icount.eq.maxstr_proc) then -#ifdef DEBUG - write (iout,* ) "jj_old",jj_old," jj",jj -#endif - call write_and_send_cconf(icount,jj_old,jj,Next) - jj_old=jj+1 - icount=0 - endif - return - end subroutine add_new_cconf -!------------------------------------------------------------------------------ - subroutine store_cconf_from_file(jj,icount) - - use energy_data, only: ihpb,jhpb -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" -! include "COMMON.CLUSTER" -! include "COMMON.CHAIN" -! include "COMMON.SBRIDGE" -! include "COMMON.INTERACT" -! include "COMMON.IOUNITS" -! include "COMMON.VAR" - integer :: i,j,jj,icount -! Store the conformation that has been read in - do i=1,2*nres - do j=1,3 - allcart(j,i,icount)=c(j,i) - enddo - enddo - nss_all(icount)=nss - do i=1,nss - ihpb_all(i,icount)=ihpb(i) - jhpb_all(i,icount)=jhpb(i) - enddo - return - end subroutine store_cconf_from_file -!------------------------------------------------------------------------------ - subroutine write_and_send_cconf(icount,jj_old,jj,Next) - -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" -#ifdef MPI - use MPI_data - include "mpif.h" - integer :: IERROR -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.SBRIDGE" -! include "COMMON.INTERACT" -! include "COMMON.IOUNITS" -! include "COMMON.CLUSTER" -! include "COMMON.VAR" - integer :: icount,jj_old,jj,Next -! Write the structures to a scratch file -#ifdef MPI -! Master sends the portion of conformations that have been read in to the neighbor -#ifdef DEBUG - write (iout,*) "Processor",me," entered WRITE_AND_SEND_CONF" - call flush(iout) -#endif - call MPI_Send(icount,1,MPI_INTEGER,Next,570,MPI_COMM_WORLD,IERROR) - call MPI_Send(nss_all(1),icount,MPI_INTEGER,& - Next,571,MPI_COMM_WORLD,IERROR) - call MPI_Send(ihpb_all(1,1),icount,MPI_INTEGER,& - Next,572,MPI_COMM_WORLD,IERROR) - call MPI_Send(jhpb_all(1,1),icount,MPI_INTEGER,& - Next,573,MPI_COMM_WORLD,IERROR) - call MPI_Send(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,& - Next,577,MPI_COMM_WORLD,IERROR) - call MPI_Send(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,& - Next,579,MPI_COMM_WORLD,IERROR) - call MPI_Send(allcart(1,1,1),3*icount*2*nres,& - MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR) -#endif - call dawrite_ccoords(jj_old,jj,icbase) - return - end subroutine write_and_send_cconf -!------------------------------------------------------------------------------ -#ifdef MPI - subroutine receive_and_pass_cconf(icount,jj_old,jj,Previous,Next) - - use MPI_data -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" - include "mpif.h" - integer :: IERROR !,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -! include "COMMON.CHAIN" -! include "COMMON.SBRIDGE" -! include "COMMON.INTERACT" -! include "COMMON.IOUNITS" -! include "COMMON.VAR" -! include "COMMON.GEO" -! include "COMMON.CLUSTER" - integer :: i,j,k,icount,jj_old,jj,Previous,Next - icount=1 -#ifdef DEBUG - write (iout,*) "Processor",me," entered RECEIVE_AND_PASS_CONF" - call flush(iout) -#endif - do while (icount.gt.0) - call MPI_Recv(icount,1,MPI_INTEGER,Previous,570,MPI_COMM_WORLD,& - STATUS,IERROR) - call MPI_Send(icount,1,MPI_INTEGER,Next,570,MPI_COMM_WORLD,& - IERROR) -#ifdef DEBUG - write (iout,*) "Processor",me," icount",icount -#endif - if (icount.eq.0) return - call MPI_Recv(nss_all(1),icount,MPI_INTEGER,& - Previous,571,MPI_COMM_WORLD,STATUS,IERROR) - call MPI_Send(nss_all(1),icount,MPI_INTEGER,& - Next,571,MPI_COMM_WORLD,IERROR) - call MPI_Recv(ihpb_all(1,1),icount,MPI_INTEGER,& - Previous,572,MPI_COMM_WORLD,STATUS,IERROR) - call MPI_Send(ihpb_all(1,1),icount,MPI_INTEGER,& - Next,572,MPI_COMM_WORLD,IERROR) - call MPI_Recv(jhpb_all(1,1),icount,MPI_INTEGER,& - Previous,573,MPI_COMM_WORLD,STATUS,IERROR) - call MPI_Send(jhpb_all(1,1),icount,MPI_INTEGER,& - Next,573,MPI_COMM_WORLD,IERROR) - call MPI_Recv(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,& - Previous,577,MPI_COMM_WORLD,STATUS,IERROR) - call MPI_Send(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,& - Next,577,MPI_COMM_WORLD,IERROR) - call MPI_Recv(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,& - Previous,579,MPI_COMM_WORLD,STATUS,IERROR) - call MPI_Send(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,& - Next,579,MPI_COMM_WORLD,IERROR) - call MPI_Recv(allcart(1,1,1),3*icount*2*nres,& - MPI_REAL,Previous,580,MPI_COMM_WORLD,STATUS,IERROR) - call MPI_Send(allcart(1,1,1),3*icount*2*nres,& - MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR) - jj=jj_old+icount-1 - call dawrite_ccoords(jj_old,jj,icbase) - jj_old=jj+1 -#ifdef DEBUG - write (iout,*) "Processor",me," received",icount," conformations" - do i=1,icount - write (iout,'(8f10.4)') (allcart(l,k,i),l=1,3,k=1,nres) - write (iout,'(8f10.4)')((allcart(l,k,i+nres),l=1,3,k=nnt,nct) - write (iout,'(e15.5,16i5)') entfac(i) - enddo -#endif - enddo - return - end subroutine receive_and_pass_cconf -#endif -!------------------------------------------------------------------------------ - subroutine daread_ccoords(istart_conf,iend_conf) - -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" -#ifdef MPI - use MPI_data - include "mpif.h" -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.CLUSTER" -! include "COMMON.IOUNITS" -! include "COMMON.INTERACT" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" - integer :: istart_conf,iend_conf - integer :: i,j,ij,ii,iii - integer :: len - character(len=16) :: form,acc - character(len=32) :: nam -! -! Read conformations off a DA scratchfile. -! -#ifdef DEBUG - write (iout,*) "DAREAD_COORDS" - write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf - inquire(unit=icbase,name=nam,recl=len,form=form,access=acc) - write (iout,*) "len=",len," form=",form," acc=",acc - write (iout,*) "nam=",nam - call flush(iout) -#endif - do ii=istart_conf,iend_conf - ij = ii - istart_conf + 1 - iii=list_conf(ii) -#ifdef DEBUG - write (iout,*) "Reading binary file, record",iii," ii",ii - call flush(iout) -#endif - read(icbase,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),& - ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),& - nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss),& - entfac(ii),rmstb(ii) -#ifdef DEBUG - write (iout,*) ii,iii,ij,entfac(ii) - write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres) - write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),& - i=nnt+nres,nct+nres) - write (iout,'(2e15.5)') entfac(ij) - write (iout,'(16i5)') nss_all(ij),(ihpb_all(i,ij),& - jhpb_all(i,ij),i=1,nss) - call flush(iout) -#endif - enddo - return - end subroutine daread_ccoords -!------------------------------------------------------------------------------ - subroutine dawrite_ccoords(istart_conf,iend_conf,unit_out) - -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" -#ifdef MPI - use MPI_data - include "mpif.h" -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.INTERACT" -! include "COMMON.IOUNITS" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.CLUSTER" - integer :: istart_conf,iend_conf - integer :: i,j,ii,ij,iii,unit_out - integer :: len - character(len=16) :: form,acc - character(len=32) :: nam -! -! Write conformations to a DA scratchfile. -! -#ifdef DEBUG - write (iout,*) "DAWRITE_COORDS" - write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf - write (iout,*) "lenrec",lenrec - inquire(unit=unit_out,name=nam,recl=len,form=form,access=acc) - write (iout,*) "len=",len," form=",form," acc=",acc - write (iout,*) "nam=",nam - call flush(iout) -#endif - do ii=istart_conf,iend_conf - iii=list_conf(ii) - ij = ii - istart_conf + 1 -#ifdef DEBUG - write (iout,*) "Writing binary file, record",iii," ii",ii - call flush(iout) -#endif - write(unit_out,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),& - ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),& - nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij)),& - entfac(ii),rmstb(ii) -#ifdef DEBUG - write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres) - write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),i=nnt+nres,& - nct+nres) - write (iout,'(2e15.5)') entfac(ij) - write (iout,'(16i5)') nss_all(ij),(ihpb(i,ij),jhpb(i,ij),i=1,& - nss_all(ij)) - call flush(iout) -#endif - enddo - return - end subroutine dawrite_ccoords -!----------------------------------------------------------------------------- -! readrtns.F -!----------------------------------------------------------------------------- - subroutine read_control -! -! Read molecular data -! - use energy_data, only: rescale_mode,distchainmax,ipot !,temp0 - use control_data, only: titel,outpdb,outmol2,refstr,pdbref,& - iscode,symetr,punch_dist,print_dist,nstart,nend,& - caonly,iopt,efree,lprint_cart,lprint_int -! implicit none -! include 'DIMENSIONS' -! include 'sizesclu.dat' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.CLUSTER' -! include 'COMMON.CHAIN' -! include 'COMMON.HEADER' -! include 'COMMON.FFIELD' -! include 'COMMON.FREE' -! include 'COMMON.INTERACT' - character(len=320) :: controlcard !,ucase -!#ifdef MPL -! include 'COMMON.INFO' -!#endif - integer :: i - - read (INP,'(a80)') titel - call card_concat(controlcard,.true.) - - call readi(controlcard,'NRES',nres,0) - -! call alloc_clust_arrays - allocate(rcutoff(max_cut+1)) !(max_cut+1) - allocate(beta_h(maxT)) !(maxT) - allocate(mult(nres)) !(maxres) - - - call readi(controlcard,'RESCALE',rescale_mode,2) - call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) - write (iout,*) "DISTCHAINMAX",distchainmax - call readi(controlcard,'PDBOUT',outpdb,0) - call readi(controlcard,'MOL2OUT',outmol2,0) - refstr=(index(controlcard,'REFSTR').gt.0) - write (iout,*) "REFSTR",refstr - pdbref=(index(controlcard,'PDBREF').gt.0) - iscode=index(controlcard,'ONE_LETTER') - tree=(index(controlcard,'MAKE_TREE').gt.0) - min_var=(index(controlcard,'MINVAR').gt.0) - plot_tree=(index(controlcard,'PLOT_TREE').gt.0) - punch_dist=(index(controlcard,'PUNCH_DIST').gt.0) - call readi(controlcard,'NCUT',ncut,1) - call readi(controlcard,'SYM',symetr,1) - write (iout,*) 'sym', symetr - call readi(controlcard,'NSTART',nstart,0) - call readi(controlcard,'NEND',nend,0) - call reada(controlcard,'ECUT',ecut,10.0d0) - call reada(controlcard,'PROB',prob_limit,0.99d0) - write (iout,*) "Probability limit",prob_limit - lgrp=(index(controlcard,'LGRP').gt.0) - caonly=(index(controlcard,'CA_ONLY').gt.0) - print_dist=(index(controlcard,'PRINT_DIST').gt.0) - call multreada(controlcard,'CUTOFF',rcutoff,ncut,-1.0d0) - call readi(controlcard,'IOPT',iopt,2) - lside = index(controlcard,"SIDE").gt.0 - efree = index(controlcard,"EFREE").gt.0 - call readi(controlcard,'NTEMP',nT,1) - write (iout,*) "nT",nT -!el call reada(controlcard,'TEMP0',temp0,300.0d0) !el - call multreada(controlcard,'TEMPER',beta_h,nT,300.0d0) - write (iout,*) "nT",nT - write (iout,*) 'beta_h',(beta_h(i),i=1,nT) - do i=1,nT - beta_h(i)=1.0d0/(1.987D-3*beta_h(i)) - enddo - write (iout,*) 'beta_h',(beta_h(i),i=1,nT) - lprint_cart=index(controlcard,"PRINT_CART") .gt.0 - lprint_int=index(controlcard,"PRINT_INT") .gt.0 - if (min_var) iopt=1 - return - end subroutine read_control -!----------------------------------------------------------------------------- - subroutine molread -! -! Read molecular data. -! - use geometry_data, only: nsup,cref,nres0,nstart_sup,nstart_seq,dc - use energy_data!, only: wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,& -! wang,wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,& -! wturn3,wturn4,wturn6,wvdwpp,weights - use control_data, only: titel,nstart,nend,pdbref,refstr,iscode,& - indpdb - use geometry, only: chainbuild,alloc_geo_arrays - use energy, only: alloc_ener_arrays - use control, only: rescode,setup_var,init_int_table - use conform_compar, only: contact -! implicit none -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.LOCAL' -! include 'COMMON.NAMES' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' -! include 'COMMON.CONTACTS' -! include 'COMMON.TIME1' -!#ifdef MPL -! include 'COMMON.INFO' -!#endif - character(len=4) :: sequence(nres) !(maxres) - character(len=800) :: weightcard -! integer rescode - real(kind=8) :: x(6*nres) !(maxvar) - integer :: itype_pdb(nres) !(maxres) -! logical seq_comp - integer :: i,j,kkk -! -! Body -! -!el allocate(weights(n_ene)) - allocate(weights(max_ene)) - call alloc_geo_arrays - call alloc_ener_arrays -!----------------------------- - allocate(c(3,2*nres+2)) !(3,maxres2+2) maxres2=2*maxres - allocate(dc(3,0:2*nres+2)) !(3,0:maxres2) - allocate(itype(nres+2)) !(maxres) - allocate(itel(nres+2)) - - do i=1,2*nres+2 - do j=1,3 - c(j,i)=0 - dc(j,i)=0 - enddo - enddo - do i=1,nres+2 - itype(i)=0 - itel(i)=0 - enddo -!-------------------------- -! Read weights of the subsequent energy terms. - call card_concat(weightcard,.true.) - call reada(weightcard,'WSC',wsc,1.0d0) - call reada(weightcard,'WLONG',wsc,wsc) - call reada(weightcard,'WSCP',wscp,1.0d0) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) !!! el - if (index(weightcard,'SOFT').gt.0) ipot=6 -! 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - weights(1)=wsc - weights(2)=wscp - weights(3)=welec - weights(4)=wcorr - weights(5)=wcorr5 - weights(6)=wcorr6 - weights(7)=wel_loc - weights(8)=wturn3 - weights(9)=wturn4 - weights(10)=wturn6 - weights(11)=wang - weights(12)=wscloc - weights(13)=wtor - weights(14)=wtor_d - weights(15)=wstrain - weights(16)=wvdwpp - weights(17)=wbond - weights(18)=scal14 -!el weights(19)=wsccor !!!!!!!!!!!!!!!! - weights(21)=wsccor - write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,& - wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wturn3,& - wturn4,wturn6,wsccor - 10 format (/'Energy-term weights (unscaled):'// & - 'WSCC= ',f10.6,' (SC-SC)'/ & - 'WSCP= ',f10.6,' (SC-p)'/ & - 'WELEC= ',f10.6,' (p-p electr)'/ & - 'WVDWPP= ',f10.6,' (p-p VDW)'/ & - 'WBOND= ',f10.6,' (stretching)'/ & - 'WANG= ',f10.6,' (bending)'/ & - 'WSCLOC= ',f10.6,' (SC local)'/ & - 'WTOR= ',f10.6,' (torsional)'/ & - 'WTORD= ',f10.6,' (double torsional)'/ & - 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & - 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ & - 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & - 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & - 'WCORR6= ',f10.6,' (multi-body 6th order)'/ & - 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & - 'WTURN4= ',f10.6,' (turns, 4th order)'/ & - 'WTURN6= ',f10.6,' (turns, 6th order)'/ & - 'WSCCOR= ',f10.6,' (SC-backbone torsinal correalations)') - - if (wcorr4.gt.0.0d0) then - write (iout,'(/2a/)') 'Local-electrostatic type correlation ',& - 'between contact pairs of peptide groups' - write (iout,'(2(a,f5.3/))') & - 'Cutoff on 4-6th order correlation terms: ',cutoff_corr,& - 'Range of quenching the correlation terms:',2*delt_corr - else if (wcorr.gt.0.0d0) then - write (iout,'(/2a/)') 'Hydrogen-bonding correlation ',& - 'between contact pairs of peptide groups' - endif - write (iout,'(a,f8.3)') & - 'Scaling factor of 1,4 SC-p interactions:',scal14 - write (iout,'(a,f8.3)') & - 'General scaling factor of SC-p interactions:',scalscp - r0_corr=cutoff_corr-delt_corr - do i=1,20 - aad(i,1)=scalscp*aad(i,1) - aad(i,2)=scalscp*aad(i,2) - bad(i,1)=scalscp*bad(i,1) - bad(i,2)=scalscp*bad(i,2) - enddo - - call flush(iout) - print *,'indpdb=',indpdb,' pdbref=',pdbref - -! Read sequence if not taken from the pdb file. - if (iscode.gt.0) then - read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) - else - read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) - endif -! Convert sequence to numeric code - do i=1,nres - itype(i)=rescode(i,sequence(i),iscode) - enddo - print *,nres - print '(20i4)',(itype(i),i=1,nres) - - do i=1,nres -#ifdef PROCOR - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then -#else - if (itype(i).eq.ntyp1) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (iabs(itype(i+1)).ne.20) then -#else - else if (iabs(itype(i)).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - write (iout,*) "ITEL" - do i=1,nres-1 - write (iout,*) i,itype(i),itel(i) - enddo - - print *,'Call Read_Bridge.' - call read_bridge - nnt=1 - nct=nres - print *,'NNT=',NNT,' NCT=',NCT - if (itype(1).eq.ntyp1) nnt=2 - if (itype(nres).eq.ntyp1) nct=nct-1 - if (nstart.lt.nnt) nstart=nnt - if (nend.gt.nct .or. nend.eq.0) nend=nct - write (iout,*) "nstart",nstart," nend",nend - nres0=nres -! if (pdbref) then -! read(inp,'(a)') pdbfile -! write (iout,'(2a)') 'PDB data will be read from file ',pdbfile -! open(ipdbin,file=pdbfile,status='old',err=33) -! goto 34 -! 33 write (iout,'(a)') 'Error opening PDB file.' -! stop -! 34 continue -! print *,'Begin reading pdb data' -! call readpdb -! print *,'Finished reading pdb data' -! write (iout,'(a,i3,a,i3)')'nsup=',nsup,' nstart_sup=',nstart_sup -! do i=1,nres -! itype_pdb(i)=itype(i) -! enddo -! close (ipdbin) -! write (iout,'(a,i3)') 'nsup=',nsup -! nstart_seq=nnt -! if (nsup.le.(nct-nnt+1)) then -! do i=0,nct-nnt+1-nsup -! if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then -! nstart_seq=nnt+i -! goto 111 -! endif -! enddo -! write (iout,'(a)') -! & 'Error - sequences to be superposed do not match.' -! stop -! else -! do i=0,nsup-(nct-nnt+1) -! if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) -! & then -! nstart_sup=nstart_sup+i -! nsup=nct-nnt+1 -! goto 111 -! endif -! enddo -! write (iout,'(a)') -! & 'Error - sequences to be superposed do not match.' -! endif -! 111 continue -! write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, -! & ' nstart_seq=',nstart_seq -! endif -write(iout,*)"przed ini_int_tab" - call init_int_table -write(iout,*)"po ini_int_tab" -write(iout,*)"przed setup var" - call setup_var -write(iout,*)"po setup var" - write (iout,*) "molread: REFSTR",refstr - if (refstr) then - if (.not.pdbref) then - call read_angles(inp,*38) - goto 39 - 38 write (iout,'(a)') 'Error reading reference structure.' -#ifdef MPL - call mp_stopall(Error_Msg) -#else - stop 'Error reading reference structure' -#endif - 39 call chainbuild - nstart_sup=nnt - nstart_seq=nnt - nsup=nct-nnt+1 - kkk=1 - do i=1,2*nres - do j=1,3 - cref(j,i,kkk)=c(j,i) - enddo - enddo - endif - call contact(.true.,ncont_ref,icont_ref) - endif - return - end subroutine molread -!----------------------------------------------------------------------------- - subroutine openunits -! implicit none -! include 'DIMENSIONS' - use control_data, only: from_cx,from_bx,from_cart -#ifdef MPI - use MPI_data - include "mpif.h" - character(len=3) :: liczba -! include "COMMON.MPI" -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' - integer :: lenpre,lenpot !,ilen -! external ilen - character(len=16) :: cformat,cprint -! character(len=16) ucase - integer :: lenint,lenout - call getenv('INPUT',prefix) - call getenv('OUTPUT',prefout) - call getenv('INTIN',prefintin) - call getenv('COORD',cformat) - call getenv('PRINTCOOR',cprint) - call getenv('SCRATCHDIR',scratchdir) - from_bx=.true. - from_cx=.false. - if (index(ucase(cformat),'CX').gt.0) then - from_cx=.true. - from_bx=.false. - endif - from_cart=.true. - lenpre=ilen(prefix) - lenout=ilen(prefout) - lenint=ilen(prefintin) -! Get the names and open the input files - open (inp,file=prefix(:ilen(prefix))//'.inp',status='old') -#ifdef MPI - write (liczba,'(bz,i3.3)') me - outname=prefout(:lenout)//'_clust.out_'//liczba -#else - outname=prefout(:lenout)//'_clust.out' -#endif - if (from_bx) then - intinname=prefintin(:lenint)//'.bx' - else if (from_cx) then - intinname=prefintin(:lenint)//'.cx' - else - intinname=prefintin(:lenint)//'.int' - endif - rmsname=prefintin(:lenint)//'.rms' - open (jplot,file=prefout(:ilen(prefout))//'.tex',& - status='unknown') - open (jrms,file=rmsname,status='unknown') - open(iout,file=outname,status='unknown') -! Get parameter filenames and open the parameter files. - call getenv('BONDPAR',bondname) - open (ibond,file=bondname,status='old') - call getenv('THETPAR',thetname) - open (ithep,file=thetname,status='old') - call getenv('ROTPAR',rotname) - open (irotam,file=rotname,status='old') - call getenv('TORPAR',torname) - open (itorp,file=torname,status='old') - call getenv('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call getenv('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call getenv('ELEPAR',elename) - open (ielep,file=elename,status='old') - call getenv('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') - call getenv('SIDEP',sidepname) - open (isidep1,file=sidepname,status="old") - call getenv('SCCORPAR',sccorname) - open (isccor,file=sccorname,status="old") -#ifndef OLDSCP -! -! 8/9/01 In the newest version SCp interaction constants are read from a file -! Use -DOLDSCP to use hard-coded constants instead. -! - call getenv('SCPPAR',scpname) - open (iscpp,file=scpname,status='old') -#endif - return - end subroutine openunits -!----------------------------------------------------------------------------- -! geomout.F -!----------------------------------------------------------------------------- - subroutine pdboutC(etot,rmsd,tytul) - - use energy_data, only: ihpb,jhpb,itype -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' -! include 'COMMON.TEMPFAC' - character(len=50) :: tytul - character(len=1) :: chainid(10)=(/'A','B','C','D','E','F',& - 'G','H','I','J'/) - integer :: ica(nres) - real(kind=8) :: etot,rmsd - integer :: iatom,ichain,ires,i,j,iti - - write (ipdb,'(3a,1pe15.5,a,0pf7.2)') 'REMARK ',tytul(:20),& - ' ENERGY ',etot,' RMS ',rmsd - iatom=0 - ichain=1 - ires=0 - do i=nnt,nct - iti=itype(i) - if (iti.eq.ntyp1) then - ichain=ichain+1 - ires=0 - write (ipdb,'(a)') 'TER' - else - ires=ires+1 - iatom=iatom+1 - ica(i)=iatom - write (ipdb,10) iatom,restyp(iti),chainid(ichain),& - ires,(c(j,i),j=1,3),1.0d0,tempfac(1,i) - if (iti.ne.10) then - iatom=iatom+1 - write (ipdb,20) iatom,restyp(iti),chainid(ichain),& - ires,(c(j,nres+i),j=1,3),1.0d0,tempfac(2,i) - endif - endif - enddo - write (ipdb,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.ntyp1) cycle - if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then - write (ipdb,30) ica(i),ica(i+1) - else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then - write (ipdb,30) ica(i),ica(i+1),ica(i)+1 - else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then - write (ipdb,30) ica(i),ica(i)+1 - endif - enddo - if (itype(nct).ne.10) then - write (ipdb,30) ica(nct),ica(nct)+1 - endif - do i=1,nss - write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 - enddo - write (ipdb,'(a6)') 'ENDMDL' - 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,2f6.2) - 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,2f6.2) - 30 FORMAT ('CONECT',8I5) - return - end subroutine pdboutC -!----------------------------------------------------------------------------- - subroutine cartout(igr,i,etot,free,rmsd,plik) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'sizesclu.dat' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.CLUSTER' - integer :: igr,i,j,k - real(kind=8) :: etot,free,rmsd - character(len=80) :: plik - open (igeom,file=plik,position='append') - write (igeom,'(2e15.5,f10.5,$)') etot,free,rmsd - write (igeom,'(i4,$)') & - nss_all(i),(ihpb_all(j,i),jhpb_all(j,i),j=1,nss_all(i)) - write (igeom,'(i10)') iscore(i) - write (igeom,'(8f10.5)') & - ((allcart(k,j,i),k=1,3),j=1,nres),& - ((allcart(k,j+nres,i),k=1,3),j=nnt,nct) - return - end subroutine cartout -!------------------------------------------------------------------------------ -! subroutine alloc_clust_arrays(n_conf) - -! integer :: n_conf -!COMMON.CLUSTER -! common /clu/ -! allocate(diss(maxdist)) !(maxdist) -!el allocate(energy(0:maxconf),totfree(0:maxconf)) !(0:maxconf) -! allocatable :: enetb !(max_ene,maxstr_proc) -!el allocate(entfac(maxconf)) !(maxconf) -! allocatable :: totfree_gr !(maxgr) -!el allocate(rcutoff(max_cut+1)) !(max_cut+1) -! common /clu1/ -! allocatable :: licz,iass !(maxgr) -! allocatable :: nconf !(maxgr,maxingr) -! allocatable :: iass_tot !(maxgr,max_cut) -! allocatable :: list_conf !(maxconf) -! common /alles/ -!el allocatable :: allcart !(3,maxres2,maxstr_proc) -!el allocate(rmstb(maxconf)) !(maxconf) -!el allocate(mult(nres)) !(maxres) -!el allocatable :: nss_all !(maxstr_proc) -!el allocatable :: ihpb_all,jhpb_all !(maxss,maxstr_proc) -! allocate(icc(n_conf),iscore(n_conf)) !(maxconf) -!COMMON.TEMPFAC -! common /factemp/ -! allocatable :: tempfac !(2,maxres) -!COMMON.FREE -! common /free/ -!el allocate(beta_h(maxT)) !(maxT) - -! end subroutine alloc_clust_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module io_clust diff --git a/source/cluster/main_clust.F b/source/cluster/main_clust.F deleted file mode 100644 index 15e0bd0..0000000 --- a/source/cluster/main_clust.F +++ /dev/null @@ -1,449 +0,0 @@ -C -C Program to cluster united-residue MCM results. -C - implicit none - include 'DIMENSIONS' - include 'sizesclu.dat' -#ifdef MPI - include "mpif.h" - integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) - include "COMMON.MPI" -#endif - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CLUSTER' - include 'COMMON.IOUNITS' - include 'COMMON.FREE' - logical printang(max_cut) - integer printpdb(max_cut) - integer printmol2(max_cut) - character*240 lineh - REAL CRIT(maxconf),MEMBR(maxconf) - REAL CRITVAL(maxconf-1) - INTEGER IA(maxconf),IB(maxconf) - INTEGER ICLASS(maxconf,maxconf-1),HVALS(maxconf-1) - INTEGER IORDER(maxconf-1),HEIGHT(maxconf-1) - integer nn,ndis - real*4 DISNN - DIMENSION NN(maxconf),DISNN(maxconf) - LOGICAL FLAG(maxconf) - integer i,j,k,l,m,n,len,lev,idum,ii,ind,ioffset,jj,icut,ncon, - & it,ncon_work,ind1,kkk - double precision t1,t2,tcpu,difconf - - double precision varia(maxvar) - double precision hrtime,mintime,sectime - logical eof -#ifdef MPI - call MPI_Init( IERROR ) - call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR ) - call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR ) - Master = 0 - if (ierror.gt.0) then - write(iout,*) "SEVERE ERROR - Can't initialize MPI." - call mpi_finalize(ierror) - stop - endif - if (nprocs.gt.MaxProcs+1) then - write (2,*) "Error - too many processors", - & nprocs,MaxProcs+1 - write (2,*) "Increase MaxProcs and recompile" - call MPI_Finalize(IERROR) - stop - endif -#endif - - call initialize - call openunits - call parmread - call read_control - call molread -c if (refstr) call read_ref_structure(*30) - do i=1,nres - phi(i)=0.0D0 - theta(i)=0.0D0 - alph(i)=0.0D0 - omeg(i)=0.0D0 - enddo -c write (iout,*) "Before permut" -c write (iout,*) "symetr", symetr -c call flush(iout) - call permut(symetr) -c write (iout,*) "after permut" -c call flush(iout) - print *,'MAIN: nnt=',nnt,' nct=',nct - - DO I=1,NCUT - PRINTANG(I)=.FALSE. - PRINTPDB(I)=0 - printmol2(i)=0 - IF (RCUTOFF(I).LT.0.0) THEN - RCUTOFF(I)=ABS(RCUTOFF(I)) - PRINTANG(I)=.TRUE. - PRINTPDB(I)=outpdb - printmol2(i)=outmol2 - ENDIF - ENDDO - write (iout,*) 'Number of cutoffs:',NCUT - write (iout,*) 'Cutoff values:' - DO ICUT=1,NCUT - WRITE(IOUT,'(8HRCUTOFF(,I2,2H)=,F8.1,2i2)')ICUT,RCUTOFF(ICUT), - & printpdb(icut),printmol2(icut) - ENDDO - DO I=1,NRES-3 - MULT(I)=1 - ENDDO - do i=1,maxconf - list_conf(i)=i - enddo - call read_coords(ncon,*20) - write (iout,*) 'from read_coords: ncon',ncon - - write (iout,*) "nT",nT - do iT=1,nT - write (iout,*) "iT",iT -#ifdef MPI - call work_partition(.true.,ncon) -#endif - - call probabl(iT,ncon_work,ncon,*20) - - if (ncon_work.lt.2) then - write (iout,*) "Too few conformations; clustering skipped" - exit - endif -#ifdef MPI - ndis=ncon_work*(ncon_work-1)/2 - call work_partition(.true.,ndis) -#endif - - DO I=1,NCON_work - ICC(I)=I - ENDDO - WRITE (iout,'(A80)') TITEL - t1=tcpu() -C -C CALCULATE DISTANCES -C - call daread_ccoords(1,ncon_work) - ind1=0 - DO I=1,NCON_work-1 - if (mod(i,100).eq.0) print *,'Calculating RMS i=',i - do k=1,2*nres - do l=1,3 - c(l,k)=allcart(l,k,i) - enddo - enddo - kkk=1 - do k=1,nres - do l=1,3 - cref(l,k,kkk)=c(l,k) - enddo - enddo - DO J=I+1,NCON_work - IND=IOFFSET(NCON_work,I,J) -#ifdef MPI - if (ind.ge.indstart(me) .and. ind.le.indend(me)) then -#endif - ind1=ind1+1 - DISS(IND1)=DIFCONF(I,J) -c write (iout,'(2i4,i10,f10.5)') i,j,ind,DISS(IND) -#ifdef MPI - endif -#endif - ENDDO - ENDDO - t2=tcpu() - WRITE (iout,'(/a,1pe14.5,a/)') - & 'Time for distance calculation:',T2-T1,' sec.' - t1=tcpu() - PRINT '(a)','End of distance computation' - -#ifdef MPI - call MPI_Gatherv(diss(1),scount(me),MPI_REAL,diss(1), - & scount(0),idispl(0),MPI_REAL,Master,MPI_COMM_WORLD, IERROR) - if (me.eq.master) then -#endif - open(80,file='/tmp/distance',form='unformatted') - do i=1,ndis - write(80) diss(i) - enddo - if (punch_dist) then - do i=1,ncon_work-1 - do j=i+1,ncon_work - IND=IOFFSET(NCON,I,J) - write (jrms,'(2i5,2f10.5)') i,j,diss(IND), - & energy(j)-energy(i) - enddo - enddo - endif -C -C Print out the RMS deviation matrix. -C - if (print_dist) CALL DISTOUT(NCON_work) -C -C call hierarchical clustering HC from F. Murtagh -C - N=NCON_work - LEN = (N*(N-1))/2 - write(iout,*) "-------------------------------------------" - write(iout,*) "HIERARCHICAL CLUSTERING using" - if (iopt.eq.1) then - write(iout,*) "WARD'S MINIMUM VARIANCE METHOD" - elseif (iopt.eq.2) then - write(iout,*) "SINGLE LINK METHOD" - elseif (iopt.eq.3) then - write(iout,*) "COMPLETE LINK METHOD" - elseif (iopt.eq.4) then - write(iout,*) "AVERAGE LINK (OR GROUP AVERAGE) METHOD" - elseif (iopt.eq.5) then - write(iout,*) "MCQUITTY'S METHOD" - elseif (iopt.eq.6) then - write(iout,*) "MEDIAN (GOWER'S) METHOD" - elseif (iopt.eq.7) then - write(iout,*) "CENTROID METHOD" - else - write(iout,*) "IOPT=",iopt," IS INVALID, use 1-7" - write(*,*) "IOPT=",iopt," IS INVALID, use 1-7" - stop - endif - write(iout,*) - write(iout,*) "hc.f by F. Murtagh, ESA/ESO/STECF, Garching" - write(iout,*) "February 1986" - write(iout,*) "References:" - write(iout,*) "1. Multidimensional clustering algorithms" - write(iout,*) " Fionn Murtagh" - write(iout,*) " Vienna : Physica-Verlag, 1985." - write(iout,*) "2. Multivariate data analysis" - write(iout,*) " Fionn Murtagh and Andre Heck" - write(iout,*) " Kluwer Academic Publishers, 1987" - write(iout,*) "-------------------------------------------" - write(iout,*) - -#ifdef DEBUG - write (iout,*) "The TOTFREE array" - do i=1,ncon_work - write (iout,'(2i5,f10.5)') i,list_conf(i),totfree(i) - enddo -#endif - call flush(iout) - CALL HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,DISS) - LEV = N-1 - write (iout,*) "n",n," ncon_work",ncon_work," lev",lev - if (lev.lt.2) then - write (iout,*) "Too few conformations to cluster." - goto 192 - endif - CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT) -c CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL) - - do i=1,maxgr - licz(i)=0 - enddo - icut=1 - i=1 - NGR=i+1 - do j=1,n - licz(iclass(j,i))=licz(iclass(j,i))+1 - nconf(iclass(j,i),licz(iclass(j,i)))=j -c write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)), -c & nconf(iclass(j,i),licz(iclass(j,i))) - enddo - do i=1,lev-1 - - idum=lev-i - DO L=1,LEV - IF (HEIGHT(L).EQ.IDUM) GOTO 190 - ENDDO - 190 IDUM=L - write(IOUT,*) "i+1",i+1," idum",idum," critval",CRITVAL(IDUM), - & " icut",icut," cutoff",rcutoff(icut) - IF (CRITVAL(IDUM).LT. RCUTOFF(ICUT)) THEN - WRITE (iout,'(/a,f10.5)') 'AT CUTOFF:',rcutoff(icut) - write (iout,'(a,f8.2)') 'Maximum distance found:', - & CRITVAL(IDUM) - CALL SRTCLUST(ICUT,ncon_work,iT) - CALL TRACK(ICUT) - CALL WRTCLUST(ncon_work,ICUT,PRINTANG,PRINTPDB,PRINTMOL2,iT) - icut=icut+1 - if (icut.gt.ncut) goto 191 - ENDIF - NGR=i+1 - do l=1,maxgr - licz(l)=0 - enddo - do j=1,n - licz(iclass(j,i))=licz(iclass(j,i))+1 - nconf(iclass(j,i),licz(iclass(j,i)))=j -c write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)), -c & nconf(iclass(j,i),licz(iclass(j,i))) -cd print *,j,iclass(j,i), -cd & licz(iclass(j,i)),nconf(iclass(j,i),licz(iclass(j,i))) - enddo - enddo - 191 continue -C - if (plot_tree) then - CALL WRITRACK - CALL PLOTREE - endif -C - t2=tcpu() - WRITE (iout,'(/a,1pe14.5,a/)') - & 'Total time for clustering:',T2-T1,' sec.' - -#ifdef MPI - endif -#endif - 192 continue - enddo -C - close(icbase,status="delete") -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop '********** Program terminated normally.' - 20 write (iout,*) "Error reading coordinates" -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop - 30 write (iout,*) "Error reading reference structure" -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop - end -c--------------------------------------------------------------------------- - double precision function difconf(icon,jcon) - implicit none - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.CONTROL' - include 'COMMON.CLUSTER' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - logical non_conv - double precision przes(3),obrot(3,3) - double precision xx(3,maxres2),yy(3,maxres2) - integer i,ii,j,icon,jcon,kkk,nperm,chalen,zzz - integer iaperm,ibezperm,run - double precision rms,rmsmina -c write (iout,*) "tu dochodze" - rmsmina=10d10 - nperm=1 - do i=1,symetr - nperm=i*nperm - enddo -c write (iout,*) "nperm",nperm - call permut(symetr) -c write (iout,*) "tabperm", tabperm(1,1) - do kkk=1,nperm - if (lside) then - ii=0 - chalen=int((nend-nstart+2)/symetr) - do run=1,symetr - do i=nstart,(nstart+chalen-1) - zzz=tabperm(kkk,run) -c write (iout,*) "tutaj",zzz - ii=ii+1 - iaperm=(zzz-1)*chalen+i - ibezperm=(run-1)*chalen+i - do j=1,3 - xx(j,ii)=allcart(j,iaperm,jcon) - yy(j,ii)=cref(j,ibezperm,kkk) - enddo - enddo - enddo - do run=1,symetr - do i=nstart,(nstart+chalen-1) - zzz=tabperm(kkk,run) - ii=ii+1 - iaperm=(zzz-1)*chalen+i - ibezperm=(run-1)*chalen+i -c if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - xx(j,ii)=allcart(j,iaperm+nres,jcon) - yy(j,ii)=cref(j,ibezperm+nres,kkk) - enddo - enddo -c endif - enddo - call fitsq(rms,xx(1,1),yy(1,1),ii,przes,obrot,non_conv) - else - chalen=int((nct-nnt+2)/symetr) - do run=1,symetr - do i=nnt,(nnt+chalen-1) - zzz=tabperm(kkk,run) -c write (iout,*) "tu szukaj", zzz,run,kkk - iaperm=(zzz-1)*chalen+i - ibezperm=(run-1)*chalen+i -c do i=nnt,nct - do j=1,3 - c(j,i)=allcart(j,iaperm,jcon) - enddo - enddo - enddo - call fitsq(rms,c(1,nstart),cref(1,nstart,kkk),nend-nstart+1, - & przes, - & obrot,non_conv) - endif - if (rms.lt.0.0) then - print *,'error, rms^2 = ',rms,icon,jcon - stop - endif - if (non_conv) print *,non_conv,icon,jcon - if (rmsmina.gt.rms) rmsmina=rms - enddo - difconf=dsqrt(rmsmina) - RETURN - END -C------------------------------------------------------------------------------ - subroutine distout(ncon) - implicit none - include 'DIMENSIONS' - include 'sizesclu.dat' - integer ncol,ncon - parameter (ncol=10) - include 'COMMON.IOUNITS' - include 'COMMON.CLUSTER' - integer i,j,k,jlim,jlim1,nlim,ind,ioffset - real*4 b - dimension b(ncol) - write (iout,'(a)') 'The distance matrix' - do 1 i=1,ncon,ncol - nlim=min0(i+ncol-1,ncon) - write (iout,1000) (k,k=i,nlim) - write (iout,'(8h--------,10a)') ('-------',k=i,nlim) - 1000 format (/8x,10(i4,3x)) - 1020 format (/1x,80(1h-)/) - do 2 j=i,ncon - jlim=min0(j,nlim) - if (jlim.eq.j) then - b(jlim-i+1)=0.0d0 - jlim1=jlim-1 - else - jlim1=jlim - endif - do 3 k=i,jlim1 - if (j.lt.k) then - IND=IOFFSET(NCON,j,k) - else - IND=IOFFSET(NCON,k,j) - endif - 3 b(k-i+1)=diss(IND) - write (iout,1010) j,(b(k),k=1,jlim-i+1) - 2 continue - 1 continue - 1010 format (i5,3x,10(f6.2,1x)) - return - end diff --git a/source/cluster/probabl.F90 b/source/cluster/probabl.F90 new file mode 100644 index 0000000..4e5d092 --- /dev/null +++ b/source/cluster/probabl.F90 @@ -0,0 +1,361 @@ + module probability +!----------------------------------------------------------------------------- + use clust_data + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!---------------------------------------------------------------------------- +! probabl.f90 +!---------------------------------------------------------------------------- + subroutine probabl(ib,nlist,ncon,*) +! construct the conformational ensembles at REMD temperatures +! implicit none +! include "DIMENSIONS" +! include "sizesclu.dat" + use io_units + use io_clust, only: daread_ccoords + use geometry_data, only: nres,c + use energy_data, only: nss,ihpb,jhpb,max_ene + use geometry, only: int_from_cart1 + use energy, only: etotal,rescale_weights + use energy, only: rescale_mode,enerprint,weights +#ifdef MPI + use MPI_data + include "mpif.h" +! include "COMMON.MPI" + integer :: ierror,errcode !,status(MPI_STATUS_SIZE) +#endif +! include "COMMON.IOUNITS" +! include "COMMON.FREE" +! include "COMMON.FFIELD" +! include "COMMON.INTERACT" +! include "COMMON.SBRIDGE" +! include "COMMON.CHAIN" +! include "COMMON.CLUSTER" + real(kind=4) :: csingle(3,2*nres) + real(kind=8) :: fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl,& + eprim,ebis,temper,kfac=2.4d0,T0=300.0d0 + real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ebe,etors,escloc,& + ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,& + eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,& + evdw_t + integer :: i,ii,ik,iproc,iscor,j,k,l,ib,nlist,ncon + real(kind=8) :: qfree,sumprob,eini,efree,rmsdev + character(len=80) :: bxname + character(len=2) :: licz1 + character(len=5) :: ctemper +! integer ilen +! external ilen + real(kind=4) :: Fdimless(maxconf),Fdimless_(maxconf) + real(kind=8) :: totfree_(0:maxconf),entfac_(maxconf) + real(kind=8) :: energia(0:max_ene) + integer,dimension(0:nprocs) :: scount_ + + do i=1,ncon + list_conf(i)=i + enddo +! do i=1,ncon +! write (iout,*) i,list_conf(i) +! enddo +#ifdef MPI + write (iout,*) me," indstart",indstart(me)," indend",indend(me) + call daread_ccoords(indstart(me),indend(me)) +#endif +! write (iout,*) "ncon",ncon + temper=1.0d0/(beta_h(ib)*1.987D-3) +!elwrite(iout,*)"rescale_mode", rescale_mode +! write (iout,*) "ib",ib," beta_h",beta_h(ib)," temper",temper +! quot=1.0d0/(T0*beta_h(ib)*1.987D-3) +! quotl=1.0d0 +! kfacl=1.0d0 +! do l=1,5 +! quotl1=quotl +! quotl=quotl*quot +! kfacl=kfacl*kfac +! fT(l)=kfacl/(kfacl-1.0d0+quotl) +! enddo +! EL start old rescale------------------------------- +! if (rescale_mode.eq.1) then +! quot=1.0d0/(T0*beta_h(ib)*1.987D-3) +! quotl=1.0d0 +! kfacl=1.0d0 +! do l=1,5 +! quotl1=quotl +! quotl=quotl*quot +! kfacl=kfacl*kfac +! fT(l)=kfacl/(kfacl-1.0d0+quotl) +! enddo +!if defined(FUNCTH) +! ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & +! 320.0d0 +! ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) +! ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & +! /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +!elif defined(FUNCT) +! fT(6)=betaT/T0 +! ftprim(6)=1.0d0/T0 +! ftbis(6)=0.0d0 +!else +! fT(6)=1.0d0 +! ftprim(6)=0.0d0 +! ftbis(6)=0.0d0 +!endif +! +! else if (rescale_mode.eq.2) then +! quot=1.0d0/(T0*beta_h(ib)*1.987D-3) +! quotl=1.0d0 +! do l=1,5 +! quotl=quotl*quot +! fT(l)=1.12692801104297249644d0/ & +! dlog(dexp(quotl)+dexp(-quotl)) +! enddo +!el write (iout,*) 1.0d0/(beta_h(ib)*1.987D-3) +!c call flush(iout) +!if defined(FUNCTH) +! ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & +! 320.0d0 +! ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) +! ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & +! /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +!elif defined(FUNCT) +! fT(6)=betaT/T0 +! ftprim(6)=1.0d0/T0 +! ftbis(6)=0.0d0 +!else +! fT(6)=1.0d0 +! ftprim(6)=0.0d0 +! ftbis(6)=0.0d0 +!endif +! endif +!EL end old rescele---------------------- +! + call rescale_weights(1.0d0/(beta_h(ib)*1.987D-3)) + +#ifdef MPI + do i=1,scount(me) + ii=i+indstart(me)-1 +#else + do i=1,ncon + ii=i +#endif +! write (iout,*) "i",i," ii",ii +! call flush(iout) + if (ib.eq.1) then + do j=1,nres + do k=1,3 + c(k,j)=allcart(k,j,i) + c(k,j+nres)=allcart(k,j+nres,i) + enddo + enddo + do k=1,3 + c(k,nres+1)=c(k,1) + c(k,nres+nres)=c(k,nres) + enddo +!el do j=1,2*nres +! do k=1,3 +!write(iout,*)"c, k, j",k,j,c(k,j) +! enddo +!el enddo + nss=nss_all(i) + do j=1,nss + ihpb(j)=ihpb_all(j,i) + jhpb(j)=jhpb_all(j,i) + enddo + call int_from_cart1(.false.) +! call etotal(energia(0),fT) + call etotal(energia) + totfree(i)=energia(0) +! write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) +! write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) +! call enerprint(energia) +! call pdbout(totfree(i),16,i) +#ifdef DEBUG + write (iout,*) i," energia",(energia(j),j=0,21) + write (iout,*) "etot", etot +! write (iout,*) "ft(6)", ft(6) +#endif + do k=1,max_ene + enetb(k,i)=energia(k) + enddo + endif +!el evdw=enetb(1,i) +! write (iout,*) evdw + etot=energia(0) +#ifdef SCP14 +!el evdw2_14=enetb(17,i) + evdw2_14=enetb(18,i) + evdw2=enetb(2,i)+evdw2_14 +#else + evdw2=enetb(2,i) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i) + evdw1=enetb(16,i) +#else + ees=enetb(3,i) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i) + ecorr5=enetb(5,i) + ecorr6=enetb(6,i) + eel_loc=enetb(7,i) + eello_turn3=enetb(8,i) + eello_turn4=enetb(9,i) + eturn6=enetb(10,i) + ebe=enetb(11,i) + escloc=enetb(12,i) + etors=enetb(13,i) + etors_d=enetb(14,i) + ehpb=enetb(15,i) +! estr=enetb(18,i) + estr=enetb(17,i) +! esccor=enetb(19,i) + esccor=enetb(21,i) +! edihcnstr=enetb(20,i) + edihcnstr=enetb(19,i) +!#ifdef SPLITELE +! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ +! &ft(1)*welec*ees+wvdwpp*evdw1 +! & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +! & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 +! & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 +! & +ft(2)*wturn3*eello_turn3 +! & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc +! & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor +! & +wbond*estr +!#else +! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*(ees+evdw1) +! & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +! & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 +! & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 +! & +ft(2)*wturn3*eello_turn3 +! & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr +! & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor +! & +wbond*estr +!#endif +!#ifdef DEBUG +! write (iout,*) "etot2", etot +! write (iout,*) "evdw", wsc, evdw,evdw_t +! write (iout,*) "evdw2", wscp, evdw2 +! write (iout,*) "welec", ft(1),welec,ees +! write (iout,*) "evdw1", wvdwpp,evdw1 +! write (iout,*) "ebe",ebe,wang +!#endif + Fdimless(i)=beta_h(ib)*etot+entfac(ii) + totfree(i)=etot +#ifdef DEBUG + write (iout,*) "fdim calc", i,ii,ib,& + 1.0d0/(1.987d-3*beta_h(ib)),totfree(i),& + entfac(ii),Fdimless(i) +#endif + Fdimless_(i)=Fdimless(i) + totfree_(i)=totfree(i) + call enerprint(energia(0)) !el + enddo ! i + + do i=1,maxconf + entfac_(i)=entfac(i) + enddo + do i=0,nprocs + scount_(i)=scount(i) + enddo + +#ifdef MPI + call MPI_Gatherv(Fdimless_(1),scount_(me),& + MPI_REAL,Fdimless(1),& + scount(0),idispl(0),MPI_REAL,Master,& + MPI_COMM_WORLD, IERROR) + call MPI_Gatherv(totfree_(1),scount(me),& + MPI_DOUBLE_PRECISION,totfree(1),& + scount_(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& + MPI_COMM_WORLD, IERROR) + call MPI_Gatherv(entfac_(indstart(me)+1),scount_(me),& + MPI_DOUBLE_PRECISION,entfac(1),& + scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& + MPI_COMM_WORLD, IERROR) + + if (me.eq.Master) then +#endif +#ifdef DEBUG + write (iout,*) "The FDIMLESS array before sorting" + do i=1,ncon + write (iout,*) i,fdimless(i) + enddo +#endif + call mysort1(ncon,Fdimless,list_conf) +#ifdef DEBUG + write (iout,*) "The FDIMLESS array after sorting" + do i=1,ncon + write (iout,*) i,list_conf(i),fdimless(i) + enddo +#endif + do i=1,ncon + totfree(i)=fdimless(i) + enddo + qfree=0.0d0 + do i=1,ncon + qfree=qfree+exp(-fdimless(i)+fdimless(1)) +! write (iout,*) "fdimless", fdimless(i) + enddo + write (iout,*) "qfree",qfree !d + nlist=1 + sumprob=0.0 + write (iout,*) "ncon", ncon,maxstr_proc + do i=1,min0(ncon,maxstr_proc)-1 + sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree +#ifdef DEBUG + write (iout,*) i,ib,beta_h(ib),& + 1.0d0/(1.987d-3*beta_h(ib)),list_conf(i),& + totfree(list_conf(i)),& + -entfac(list_conf(i)),fdimless(i),sumprob +#endif + if (sumprob.gt.prob_limit) goto 122 +! if (sumprob.gt.1.00d0) goto 122 + nlist=nlist+1 + enddo + 122 continue +#ifdef MPI + endif + call MPI_Bcast(nlist, 1, MPI_INTEGER, Master, MPI_COMM_WORLD, & + IERROR) + call MPI_Bcast(list_conf,nlist,MPI_INTEGER,Master,MPI_COMM_WORLD,& + IERROR) +! do iproc=0,nprocs +! write (iout,*) "iproc",iproc," indstart",indstart(iproc), +! & " indend",indend(iproc) +! enddo +#endif +!write(iout,*)"koniec probabl" + return + end subroutine probabl +!-------------------------------------------------- + subroutine mysort1(n, x, ipermut) +! implicit none + integer :: i,j,imax,ipm,n + real(kind=4) :: x(n) + integer :: ipermut(n) + real(kind=4) :: xtemp + do i=1,n + xtemp=x(i) + imax=i + do j=i+1,n + if (x(j).lt.xtemp) then + imax=j + xtemp=x(j) + endif + enddo + x(imax)=x(i) + x(i)=xtemp + ipm=ipermut(imax) + ipermut(imax)=ipermut(i) + ipermut(i)=ipm + enddo + return + end subroutine mysort1 +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module probability diff --git a/source/cluster/probabl.f90 b/source/cluster/probabl.f90 deleted file mode 100644 index 4e5d092..0000000 --- a/source/cluster/probabl.f90 +++ /dev/null @@ -1,361 +0,0 @@ - module probability -!----------------------------------------------------------------------------- - use clust_data - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!---------------------------------------------------------------------------- -! probabl.f90 -!---------------------------------------------------------------------------- - subroutine probabl(ib,nlist,ncon,*) -! construct the conformational ensembles at REMD temperatures -! implicit none -! include "DIMENSIONS" -! include "sizesclu.dat" - use io_units - use io_clust, only: daread_ccoords - use geometry_data, only: nres,c - use energy_data, only: nss,ihpb,jhpb,max_ene - use geometry, only: int_from_cart1 - use energy, only: etotal,rescale_weights - use energy, only: rescale_mode,enerprint,weights -#ifdef MPI - use MPI_data - include "mpif.h" -! include "COMMON.MPI" - integer :: ierror,errcode !,status(MPI_STATUS_SIZE) -#endif -! include "COMMON.IOUNITS" -! include "COMMON.FREE" -! include "COMMON.FFIELD" -! include "COMMON.INTERACT" -! include "COMMON.SBRIDGE" -! include "COMMON.CHAIN" -! include "COMMON.CLUSTER" - real(kind=4) :: csingle(3,2*nres) - real(kind=8) :: fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl,& - eprim,ebis,temper,kfac=2.4d0,T0=300.0d0 - real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ebe,etors,escloc,& - ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,& - eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,& - evdw_t - integer :: i,ii,ik,iproc,iscor,j,k,l,ib,nlist,ncon - real(kind=8) :: qfree,sumprob,eini,efree,rmsdev - character(len=80) :: bxname - character(len=2) :: licz1 - character(len=5) :: ctemper -! integer ilen -! external ilen - real(kind=4) :: Fdimless(maxconf),Fdimless_(maxconf) - real(kind=8) :: totfree_(0:maxconf),entfac_(maxconf) - real(kind=8) :: energia(0:max_ene) - integer,dimension(0:nprocs) :: scount_ - - do i=1,ncon - list_conf(i)=i - enddo -! do i=1,ncon -! write (iout,*) i,list_conf(i) -! enddo -#ifdef MPI - write (iout,*) me," indstart",indstart(me)," indend",indend(me) - call daread_ccoords(indstart(me),indend(me)) -#endif -! write (iout,*) "ncon",ncon - temper=1.0d0/(beta_h(ib)*1.987D-3) -!elwrite(iout,*)"rescale_mode", rescale_mode -! write (iout,*) "ib",ib," beta_h",beta_h(ib)," temper",temper -! quot=1.0d0/(T0*beta_h(ib)*1.987D-3) -! quotl=1.0d0 -! kfacl=1.0d0 -! do l=1,5 -! quotl1=quotl -! quotl=quotl*quot -! kfacl=kfacl*kfac -! fT(l)=kfacl/(kfacl-1.0d0+quotl) -! enddo -! EL start old rescale------------------------------- -! if (rescale_mode.eq.1) then -! quot=1.0d0/(T0*beta_h(ib)*1.987D-3) -! quotl=1.0d0 -! kfacl=1.0d0 -! do l=1,5 -! quotl1=quotl -! quotl=quotl*quot -! kfacl=kfacl*kfac -! fT(l)=kfacl/(kfacl-1.0d0+quotl) -! enddo -!if defined(FUNCTH) -! ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & -! 320.0d0 -! ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) -! ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & -! /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) -!elif defined(FUNCT) -! fT(6)=betaT/T0 -! ftprim(6)=1.0d0/T0 -! ftbis(6)=0.0d0 -!else -! fT(6)=1.0d0 -! ftprim(6)=0.0d0 -! ftbis(6)=0.0d0 -!endif -! -! else if (rescale_mode.eq.2) then -! quot=1.0d0/(T0*beta_h(ib)*1.987D-3) -! quotl=1.0d0 -! do l=1,5 -! quotl=quotl*quot -! fT(l)=1.12692801104297249644d0/ & -! dlog(dexp(quotl)+dexp(-quotl)) -! enddo -!el write (iout,*) 1.0d0/(beta_h(ib)*1.987D-3) -!c call flush(iout) -!if defined(FUNCTH) -! ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & -! 320.0d0 -! ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) -! ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & -! /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) -!elif defined(FUNCT) -! fT(6)=betaT/T0 -! ftprim(6)=1.0d0/T0 -! ftbis(6)=0.0d0 -!else -! fT(6)=1.0d0 -! ftprim(6)=0.0d0 -! ftbis(6)=0.0d0 -!endif -! endif -!EL end old rescele---------------------- -! - call rescale_weights(1.0d0/(beta_h(ib)*1.987D-3)) - -#ifdef MPI - do i=1,scount(me) - ii=i+indstart(me)-1 -#else - do i=1,ncon - ii=i -#endif -! write (iout,*) "i",i," ii",ii -! call flush(iout) - if (ib.eq.1) then - do j=1,nres - do k=1,3 - c(k,j)=allcart(k,j,i) - c(k,j+nres)=allcart(k,j+nres,i) - enddo - enddo - do k=1,3 - c(k,nres+1)=c(k,1) - c(k,nres+nres)=c(k,nres) - enddo -!el do j=1,2*nres -! do k=1,3 -!write(iout,*)"c, k, j",k,j,c(k,j) -! enddo -!el enddo - nss=nss_all(i) - do j=1,nss - ihpb(j)=ihpb_all(j,i) - jhpb(j)=jhpb_all(j,i) - enddo - call int_from_cart1(.false.) -! call etotal(energia(0),fT) - call etotal(energia) - totfree(i)=energia(0) -! write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) -! write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) -! call enerprint(energia) -! call pdbout(totfree(i),16,i) -#ifdef DEBUG - write (iout,*) i," energia",(energia(j),j=0,21) - write (iout,*) "etot", etot -! write (iout,*) "ft(6)", ft(6) -#endif - do k=1,max_ene - enetb(k,i)=energia(k) - enddo - endif -!el evdw=enetb(1,i) -! write (iout,*) evdw - etot=energia(0) -#ifdef SCP14 -!el evdw2_14=enetb(17,i) - evdw2_14=enetb(18,i) - evdw2=enetb(2,i)+evdw2_14 -#else - evdw2=enetb(2,i) - evdw2_14=0.0d0 -#endif -#ifdef SPLITELE - ees=enetb(3,i) - evdw1=enetb(16,i) -#else - ees=enetb(3,i) - evdw1=0.0d0 -#endif - ecorr=enetb(4,i) - ecorr5=enetb(5,i) - ecorr6=enetb(6,i) - eel_loc=enetb(7,i) - eello_turn3=enetb(8,i) - eello_turn4=enetb(9,i) - eturn6=enetb(10,i) - ebe=enetb(11,i) - escloc=enetb(12,i) - etors=enetb(13,i) - etors_d=enetb(14,i) - ehpb=enetb(15,i) -! estr=enetb(18,i) - estr=enetb(17,i) -! esccor=enetb(19,i) - esccor=enetb(21,i) -! edihcnstr=enetb(20,i) - edihcnstr=enetb(19,i) -!#ifdef SPLITELE -! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ -! &ft(1)*welec*ees+wvdwpp*evdw1 -! & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc -! & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 -! & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 -! & +ft(2)*wturn3*eello_turn3 -! & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc -! & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor -! & +wbond*estr -!#else -! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*(ees+evdw1) -! & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc -! & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 -! & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 -! & +ft(2)*wturn3*eello_turn3 -! & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr -! & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor -! & +wbond*estr -!#endif -!#ifdef DEBUG -! write (iout,*) "etot2", etot -! write (iout,*) "evdw", wsc, evdw,evdw_t -! write (iout,*) "evdw2", wscp, evdw2 -! write (iout,*) "welec", ft(1),welec,ees -! write (iout,*) "evdw1", wvdwpp,evdw1 -! write (iout,*) "ebe",ebe,wang -!#endif - Fdimless(i)=beta_h(ib)*etot+entfac(ii) - totfree(i)=etot -#ifdef DEBUG - write (iout,*) "fdim calc", i,ii,ib,& - 1.0d0/(1.987d-3*beta_h(ib)),totfree(i),& - entfac(ii),Fdimless(i) -#endif - Fdimless_(i)=Fdimless(i) - totfree_(i)=totfree(i) - call enerprint(energia(0)) !el - enddo ! i - - do i=1,maxconf - entfac_(i)=entfac(i) - enddo - do i=0,nprocs - scount_(i)=scount(i) - enddo - -#ifdef MPI - call MPI_Gatherv(Fdimless_(1),scount_(me),& - MPI_REAL,Fdimless(1),& - scount(0),idispl(0),MPI_REAL,Master,& - MPI_COMM_WORLD, IERROR) - call MPI_Gatherv(totfree_(1),scount(me),& - MPI_DOUBLE_PRECISION,totfree(1),& - scount_(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& - MPI_COMM_WORLD, IERROR) - call MPI_Gatherv(entfac_(indstart(me)+1),scount_(me),& - MPI_DOUBLE_PRECISION,entfac(1),& - scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& - MPI_COMM_WORLD, IERROR) - - if (me.eq.Master) then -#endif -#ifdef DEBUG - write (iout,*) "The FDIMLESS array before sorting" - do i=1,ncon - write (iout,*) i,fdimless(i) - enddo -#endif - call mysort1(ncon,Fdimless,list_conf) -#ifdef DEBUG - write (iout,*) "The FDIMLESS array after sorting" - do i=1,ncon - write (iout,*) i,list_conf(i),fdimless(i) - enddo -#endif - do i=1,ncon - totfree(i)=fdimless(i) - enddo - qfree=0.0d0 - do i=1,ncon - qfree=qfree+exp(-fdimless(i)+fdimless(1)) -! write (iout,*) "fdimless", fdimless(i) - enddo - write (iout,*) "qfree",qfree !d - nlist=1 - sumprob=0.0 - write (iout,*) "ncon", ncon,maxstr_proc - do i=1,min0(ncon,maxstr_proc)-1 - sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree -#ifdef DEBUG - write (iout,*) i,ib,beta_h(ib),& - 1.0d0/(1.987d-3*beta_h(ib)),list_conf(i),& - totfree(list_conf(i)),& - -entfac(list_conf(i)),fdimless(i),sumprob -#endif - if (sumprob.gt.prob_limit) goto 122 -! if (sumprob.gt.1.00d0) goto 122 - nlist=nlist+1 - enddo - 122 continue -#ifdef MPI - endif - call MPI_Bcast(nlist, 1, MPI_INTEGER, Master, MPI_COMM_WORLD, & - IERROR) - call MPI_Bcast(list_conf,nlist,MPI_INTEGER,Master,MPI_COMM_WORLD,& - IERROR) -! do iproc=0,nprocs -! write (iout,*) "iproc",iproc," indstart",indstart(iproc), -! & " indend",indend(iproc) -! enddo -#endif -!write(iout,*)"koniec probabl" - return - end subroutine probabl -!-------------------------------------------------- - subroutine mysort1(n, x, ipermut) -! implicit none - integer :: i,j,imax,ipm,n - real(kind=4) :: x(n) - integer :: ipermut(n) - real(kind=4) :: xtemp - do i=1,n - xtemp=x(i) - imax=i - do j=i+1,n - if (x(j).lt.xtemp) then - imax=j - xtemp=x(j) - endif - enddo - x(imax)=x(i) - x(i)=xtemp - ipm=ipermut(imax) - ipermut(imax)=ipermut(i) - ipermut(i)=ipm - enddo - return - end subroutine mysort1 -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module probability diff --git a/source/cluster/track.F90 b/source/cluster/track.F90 new file mode 100644 index 0000000..542da6a --- /dev/null +++ b/source/cluster/track.F90 @@ -0,0 +1,306 @@ + module tracking +!------------------------------------------------------------------------------ + use clust_data + implicit none +!------------------------------------------------------------------------------ +! COMMON /HISTORY/ + integer :: NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) +! COMMON /PREVIOUS/ + integer :: NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) +!------------------------------------------------------------------------------ +! +! +!------------------------------------------------------------------------------ + contains +!------------------------------------------------------------------------------ + SUBROUTINE TRACK(ICUT) +! include 'DIMENSIONS' +! INCLUDE 'sizesclu.dat' +! INCLUDE 'COMMON.CLUSTER' +! COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) +! COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) + integer :: icut,igr,jgr,k,nci1 + IF (ICUT.GT.1) THEN +! Find out what of the previous families the current ones came from. + DO IGR=1,NGR + NCI1=NCONF(IGR,1) + DO JGR=1,NGRP + DO K=1,LICZP(JGR) + IF (NCI1.EQ.NCONFP(JGR,K)) THEN + IBACK(IGR,ICUT)=JGR + GOTO 10 + ENDIF + ENDDO ! K + ENDDO ! JGR + 10 CONTINUE + ENDDO ! IGR + ENDIF ! (ICUT.GT.1) +! Save current partition for subsequent backtracking. + NCUR(ICUT)=NGR + NGRP=NGR + DO IGR=1,NGR + LICZP(IGR)=LICZ(IGR) + DO K=1,LICZ(IGR) + NCONFP(IGR,K)=NCONF(IGR,K) + ENDDO ! K + ENDDO ! IGR + RETURN + END SUBROUTINE TRACK +!------------------------------------------------------------------------------ + SUBROUTINE WRITRACK + + use io_units, only: iout +! include 'DIMENSIONS' +! INCLUDE 'sizesclu.dat' +! INCLUDE 'COMMON.CLUSTER' +! include 'COMMON.IOUNITS' +! COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) +! COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) + integer :: IPART(MAXGR/5,MAXGR/5) + integer :: icut,i,j,k,ncu,ncup,npart +! do icut=2,ncut +! write (iout,'(a,f10.5)') 'Cut-off',rcutoff(icut) +! write (iout,'(16i5)') (iback(k,icut),k=1,ncur(icut)) +! enddo +! +! Print the partition history. +! + DO ICUT=2,NCUT + NCU=NCUR(ICUT) + NCUP=NCUR(ICUT-1) +!d print *,'icut=',icut,' ncu=',ncu,' ncur=',ncur + WRITE(iout,'(A,f10.5,A,f10.5)') & + 'Partition of families obtained at cut-off',RCUTOFF(ICUT-1),& + ' at cut-off',RCUTOFF(ICUT) + DO I=1,NCUP + NPART=0 +!d print *,'i=',i + DO J=1,NCU + IF (IBACK(J,ICUT).EQ.I) THEN + NPART=NPART+1 + IPART(NPART,I)=J + ENDIF +!d print *,'j=',j,' iback=',IBACK(J,ICUT),' npart=',npart + ENDDO ! J + WRITE (iout,'(16I5)') I,(IPART(K,I),K=1,NPART) + ENDDO ! I + ENDDO ! ICUT + RETURN + END SUBROUTINE WRITRACK +!------------------------------------------------------------------------------ + SUBROUTINE PLOTREE + + use io_units, only: jplot + use io_base, only: ilen +! include 'DIMENSIONS' +! INCLUDE 'sizesclu.dat' +! INCLUDE 'COMMON.CLUSTER' +! include 'COMMON.IOUNITS' +! COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) +! COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) + integer,DIMENSION(MAXGR,MAX_CUT) :: Y + integer,DIMENSION(MAXGR,MAX_CUT) :: ITREE,IFIRST,ILAST + integer,dimension(MAXGR) :: IFT,ILT,ITR + CHARACTER(len=32) :: FD + integer :: i,icut,j,k,is,iti,jf1,jf2,jl1,jl2,ncu,ncup,npart + integer :: jr1,jr2,jf11,kl,kf,nnc,iylen,ideltx,idelty + real(kind=8) :: xlen,ylen,xbox,ybox,deltx,yy + real(kind=8) :: ycur,xcur,xdraw,ydraw,delty +!el external ilen +! +! Generate the image of the tree (tentatively for LaTeX picture environment). +! +! +! First untangle the branches of the tree +! + DO I=1,NCUR(1) + ITREE(I,1)=I + ENDDO + DO ICUT=NCUT,2,-1 +! +! Determine the order of families for the (icut)th partition. +! + NCU=NCUR(ICUT) + NCUP=NCUR(ICUT-1) + NPART=0 + DO I=1,NCUP + IS=0 + IF (I.GT.1) ILAST(I-1,ICUT-1)=NPART + DO J=1,NCU + IF (IBACK(J,ICUT).EQ.I) THEN + NPART=NPART+1 + IF (IS.EQ.0) THEN + IS=1 + IFIRST(I,ICUT-1)=NPART + ENDIF + ITREE(NPART,ICUT)=J + ENDIF + ENDDO ! J + ENDDO ! I + ILAST(NCUP,ICUT-1)=NPART +!d print *,'i=',i,' ncup=',ncup,' ncu=',ncu,' npart=',npart + ENDDO ! ICUT +! diagnostic printout +!d do icut=1,ncut +!d write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut) +!d write (iout,*) 'ITREE' +!d write (iout,*) (itree(i,icut),i=1,ncur(icut)) +!d write (iout,*) 'IFIRST, ILAST' +!d write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut)) +!d enddo +! +! Propagate the order of families from cut-off #2 to cut-off #n. +! + DO ICUT=1,NCUT-1 + DO J=1,NCUR(ICUT) + IFT(J)=IFIRST(J,ICUT) + ILT(J)=ILAST(J,ICUT) + ENDDO ! J + DO J=1,NCUR(ICUT+1) + ITR(J)=ITREE(J,ICUT+1) + ENDDO + DO I=1,NCUR(ICUT) + ITI=ITREE(I,ICUT) +! write (iout,*) 'icut=',icut,' i=',i,' iti=',iti +! IF (ITI.NE.I) THEN + JF1=IFT(I) + JF2=IFT(ITI) + JL1=ILT(I) + JL2=ILT(ITI) + JR1=JL1-JF1+1 + JR2=JL2-JF2+1 +!d write (iout,*) 'jf1=',jf1,' jl1=',jl1,' jf2=',jf2, +!d & ' jl2=',jl2 +!d write (iout,*) 'jr1=',jr1,' jr2=',jr2 +! Update IFIRST and ILAST. + ILAST(I,ICUT)=IFIRST(I,ICUT)+JR2-1 + IFIRST(I+1,ICUT)=ILAST(I,ICUT)+1 +! Update ITREE. + JF11=IFIRST(I,ICUT) +!d write(iout,*) 'jf11=',jf11 + DO J=JF2,JL2 +!d write (iout,*) j,JF11+J-JF2,ITR(J) + ITREE(JF11+J-JF2,ICUT+1)=ITR(J) + ENDDO +!d write (iout,*) (ifirst(k,icut),ilast(k,icut),k=1,i) +!d write (iout,*) (itree(k,icut+1),k=1,ilast(i,icut)) +! ENDIF ! (ITI.NE.I) + ENDDO ! I + ENDDO ! ICUT +! diagnostic printout +!d do icut=1,ncut +!d write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut) +!d write (iout,*) 'ITREE' +!d write (iout,*) (itree(i,icut),i=1,ncur(icut)) +!d write (iout,*) 'IFIRST, ILAST' +!d write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut)) +!d enddo +! +! Generate the y-coordinates of the branches. +! + XLEN=400.0/(ncut-1) + YLEN=600.0 + xbox=xlen/4.0 + deltx=0.5*(xlen-xbox) + NNC=NCUR(NCUT) + ybox=ylen/(2.0*nnc) + DO J=1,NNC + Y(J,NCUT)=J*YLEN/NNC + ENDDO + DO ICUT=NCUT-1,1,-1 + NNC=NCUR(ICUT) + DO J=1,NNC + KF=IFIRST(J,ICUT) + KL=ILAST(J,ICUT) + YY=0.0 + DO K=KF,KL + YY=YY+Y(K,ICUT+1) + ENDDO + Y(J,ICUT)=YY/(KL-KF+1) + ENDDO ! J + ENDDO ! ICUT +! diagnostic output +!d do icut=1,ncut +!d write(iout,*) 'Cut-off=',rcutoff(icut) +!d write(iout,'(8f10.3)') (y(j,icut),j=1,ncur(icut)) +!d enddo +! +! Generate LaTeX script for tree plot +! + iylen=ylen +#ifdef AIX + call fdate_(fd) +#else + call fdate(fd) +#endif + write(jplot,'(80(1h%))') + write(jplot,'(a)') '% LaTeX code for minimal-tree plotting.' + write(jplot,'(3a)') '% Created by UNRES_CLUST on ',& + fd(:ilen(fd)),'.' + write(jplot,'(2a)') '% To change the dimensions use the LaTeX',& + ' \\unitlength=number command.' + write(jplot,'(a)') '% The default dimensions fit an A4 page.' + write(jplot,'(80(1h%))') + write(jplot,'(a,i5,a)') '\\begin{picture}(1,1)(0,',iylen,')' + ycur=ylen+ybox + do icut=ncut,1,-1 + xcur=xlen*(icut-1) + write(jplot,'(a,f6.1,a,f6.1,a,f4.2,a)') & + ' \\put(',xcur,',',ycur,'){',rcutoff(icut),' \\AA}' + enddo ! icut + xcur=0.0 + xdraw=xcur+xbox + nnc=ncur(1) + write(jplot,'(a,i3,a)') '% Begin cut-off',1,'.' + do j=1,nnc + ydraw=y(j,1) + ycur=ydraw-0.5*ybox + ideltx=deltx + write(jplot,'(4(a,f6.1),a,i3,a)') & + ' \\put(',xcur,',',ycur,'){\\framebox(',xbox,',',ybox,'){',& + itree(j,1),'}}' + write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & + ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,& + ',',0,'){',deltx,'}}' + enddo ! j + do icut=2,ncut + write(jplot,'(a,i3,a)') '% Begin cut-off',icut,'.' + xcur=xlen*(icut-1) + xdraw=xcur-deltx +!d print *,'icut=',icut,' xlen=',xlen,' deltx=',deltx, +!d & ' xcur=',xcur,' xdraw=',xdraw + nnc=ncur(icut) + do j=1,ncur(icut-1) + ydraw=y(ifirst(j,icut-1),icut) + delty=y(ilast(j,icut-1),icut)-y(ifirst(j,icut-1),icut) + idelty=delty + write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & + ' \\put(',xdraw,',',ydraw,'){\\line(',0,& + ',',idelty,'){',delty,'}}' + enddo + do j=1,nnc + xcur=xlen*(icut-1) + xdraw=xcur-deltx + ydraw=y(j,icut) + ycur=ydraw-0.5*ybox + ideltx=deltx + write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & + ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,& + ',',0,'){',deltx,'}}' + write(jplot,'(4(a,f6.1),a,i3,a)') & + ' \\put(',xcur,',',ycur,'){\\framebox(',xbox,',',ybox,'){',& + itree(j,icut),'}}' + if (icut.lt.ncut) then + xdraw=xcur+xbox + write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & + ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,& + ',',0,'){',deltx,'}}' + endif + enddo ! j + enddo ! icut + write(jplot,'(a)') '\\end{picture}' + RETURN + END SUBROUTINE PLOTREE +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + end module tracking diff --git a/source/cluster/track.f90 b/source/cluster/track.f90 deleted file mode 100644 index 542da6a..0000000 --- a/source/cluster/track.f90 +++ /dev/null @@ -1,306 +0,0 @@ - module tracking -!------------------------------------------------------------------------------ - use clust_data - implicit none -!------------------------------------------------------------------------------ -! COMMON /HISTORY/ - integer :: NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) -! COMMON /PREVIOUS/ - integer :: NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) -!------------------------------------------------------------------------------ -! -! -!------------------------------------------------------------------------------ - contains -!------------------------------------------------------------------------------ - SUBROUTINE TRACK(ICUT) -! include 'DIMENSIONS' -! INCLUDE 'sizesclu.dat' -! INCLUDE 'COMMON.CLUSTER' -! COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) -! COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) - integer :: icut,igr,jgr,k,nci1 - IF (ICUT.GT.1) THEN -! Find out what of the previous families the current ones came from. - DO IGR=1,NGR - NCI1=NCONF(IGR,1) - DO JGR=1,NGRP - DO K=1,LICZP(JGR) - IF (NCI1.EQ.NCONFP(JGR,K)) THEN - IBACK(IGR,ICUT)=JGR - GOTO 10 - ENDIF - ENDDO ! K - ENDDO ! JGR - 10 CONTINUE - ENDDO ! IGR - ENDIF ! (ICUT.GT.1) -! Save current partition for subsequent backtracking. - NCUR(ICUT)=NGR - NGRP=NGR - DO IGR=1,NGR - LICZP(IGR)=LICZ(IGR) - DO K=1,LICZ(IGR) - NCONFP(IGR,K)=NCONF(IGR,K) - ENDDO ! K - ENDDO ! IGR - RETURN - END SUBROUTINE TRACK -!------------------------------------------------------------------------------ - SUBROUTINE WRITRACK - - use io_units, only: iout -! include 'DIMENSIONS' -! INCLUDE 'sizesclu.dat' -! INCLUDE 'COMMON.CLUSTER' -! include 'COMMON.IOUNITS' -! COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) -! COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) - integer :: IPART(MAXGR/5,MAXGR/5) - integer :: icut,i,j,k,ncu,ncup,npart -! do icut=2,ncut -! write (iout,'(a,f10.5)') 'Cut-off',rcutoff(icut) -! write (iout,'(16i5)') (iback(k,icut),k=1,ncur(icut)) -! enddo -! -! Print the partition history. -! - DO ICUT=2,NCUT - NCU=NCUR(ICUT) - NCUP=NCUR(ICUT-1) -!d print *,'icut=',icut,' ncu=',ncu,' ncur=',ncur - WRITE(iout,'(A,f10.5,A,f10.5)') & - 'Partition of families obtained at cut-off',RCUTOFF(ICUT-1),& - ' at cut-off',RCUTOFF(ICUT) - DO I=1,NCUP - NPART=0 -!d print *,'i=',i - DO J=1,NCU - IF (IBACK(J,ICUT).EQ.I) THEN - NPART=NPART+1 - IPART(NPART,I)=J - ENDIF -!d print *,'j=',j,' iback=',IBACK(J,ICUT),' npart=',npart - ENDDO ! J - WRITE (iout,'(16I5)') I,(IPART(K,I),K=1,NPART) - ENDDO ! I - ENDDO ! ICUT - RETURN - END SUBROUTINE WRITRACK -!------------------------------------------------------------------------------ - SUBROUTINE PLOTREE - - use io_units, only: jplot - use io_base, only: ilen -! include 'DIMENSIONS' -! INCLUDE 'sizesclu.dat' -! INCLUDE 'COMMON.CLUSTER' -! include 'COMMON.IOUNITS' -! COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT) -! COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR) - integer,DIMENSION(MAXGR,MAX_CUT) :: Y - integer,DIMENSION(MAXGR,MAX_CUT) :: ITREE,IFIRST,ILAST - integer,dimension(MAXGR) :: IFT,ILT,ITR - CHARACTER(len=32) :: FD - integer :: i,icut,j,k,is,iti,jf1,jf2,jl1,jl2,ncu,ncup,npart - integer :: jr1,jr2,jf11,kl,kf,nnc,iylen,ideltx,idelty - real(kind=8) :: xlen,ylen,xbox,ybox,deltx,yy - real(kind=8) :: ycur,xcur,xdraw,ydraw,delty -!el external ilen -! -! Generate the image of the tree (tentatively for LaTeX picture environment). -! -! -! First untangle the branches of the tree -! - DO I=1,NCUR(1) - ITREE(I,1)=I - ENDDO - DO ICUT=NCUT,2,-1 -! -! Determine the order of families for the (icut)th partition. -! - NCU=NCUR(ICUT) - NCUP=NCUR(ICUT-1) - NPART=0 - DO I=1,NCUP - IS=0 - IF (I.GT.1) ILAST(I-1,ICUT-1)=NPART - DO J=1,NCU - IF (IBACK(J,ICUT).EQ.I) THEN - NPART=NPART+1 - IF (IS.EQ.0) THEN - IS=1 - IFIRST(I,ICUT-1)=NPART - ENDIF - ITREE(NPART,ICUT)=J - ENDIF - ENDDO ! J - ENDDO ! I - ILAST(NCUP,ICUT-1)=NPART -!d print *,'i=',i,' ncup=',ncup,' ncu=',ncu,' npart=',npart - ENDDO ! ICUT -! diagnostic printout -!d do icut=1,ncut -!d write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut) -!d write (iout,*) 'ITREE' -!d write (iout,*) (itree(i,icut),i=1,ncur(icut)) -!d write (iout,*) 'IFIRST, ILAST' -!d write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut)) -!d enddo -! -! Propagate the order of families from cut-off #2 to cut-off #n. -! - DO ICUT=1,NCUT-1 - DO J=1,NCUR(ICUT) - IFT(J)=IFIRST(J,ICUT) - ILT(J)=ILAST(J,ICUT) - ENDDO ! J - DO J=1,NCUR(ICUT+1) - ITR(J)=ITREE(J,ICUT+1) - ENDDO - DO I=1,NCUR(ICUT) - ITI=ITREE(I,ICUT) -! write (iout,*) 'icut=',icut,' i=',i,' iti=',iti -! IF (ITI.NE.I) THEN - JF1=IFT(I) - JF2=IFT(ITI) - JL1=ILT(I) - JL2=ILT(ITI) - JR1=JL1-JF1+1 - JR2=JL2-JF2+1 -!d write (iout,*) 'jf1=',jf1,' jl1=',jl1,' jf2=',jf2, -!d & ' jl2=',jl2 -!d write (iout,*) 'jr1=',jr1,' jr2=',jr2 -! Update IFIRST and ILAST. - ILAST(I,ICUT)=IFIRST(I,ICUT)+JR2-1 - IFIRST(I+1,ICUT)=ILAST(I,ICUT)+1 -! Update ITREE. - JF11=IFIRST(I,ICUT) -!d write(iout,*) 'jf11=',jf11 - DO J=JF2,JL2 -!d write (iout,*) j,JF11+J-JF2,ITR(J) - ITREE(JF11+J-JF2,ICUT+1)=ITR(J) - ENDDO -!d write (iout,*) (ifirst(k,icut),ilast(k,icut),k=1,i) -!d write (iout,*) (itree(k,icut+1),k=1,ilast(i,icut)) -! ENDIF ! (ITI.NE.I) - ENDDO ! I - ENDDO ! ICUT -! diagnostic printout -!d do icut=1,ncut -!d write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut) -!d write (iout,*) 'ITREE' -!d write (iout,*) (itree(i,icut),i=1,ncur(icut)) -!d write (iout,*) 'IFIRST, ILAST' -!d write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut)) -!d enddo -! -! Generate the y-coordinates of the branches. -! - XLEN=400.0/(ncut-1) - YLEN=600.0 - xbox=xlen/4.0 - deltx=0.5*(xlen-xbox) - NNC=NCUR(NCUT) - ybox=ylen/(2.0*nnc) - DO J=1,NNC - Y(J,NCUT)=J*YLEN/NNC - ENDDO - DO ICUT=NCUT-1,1,-1 - NNC=NCUR(ICUT) - DO J=1,NNC - KF=IFIRST(J,ICUT) - KL=ILAST(J,ICUT) - YY=0.0 - DO K=KF,KL - YY=YY+Y(K,ICUT+1) - ENDDO - Y(J,ICUT)=YY/(KL-KF+1) - ENDDO ! J - ENDDO ! ICUT -! diagnostic output -!d do icut=1,ncut -!d write(iout,*) 'Cut-off=',rcutoff(icut) -!d write(iout,'(8f10.3)') (y(j,icut),j=1,ncur(icut)) -!d enddo -! -! Generate LaTeX script for tree plot -! - iylen=ylen -#ifdef AIX - call fdate_(fd) -#else - call fdate(fd) -#endif - write(jplot,'(80(1h%))') - write(jplot,'(a)') '% LaTeX code for minimal-tree plotting.' - write(jplot,'(3a)') '% Created by UNRES_CLUST on ',& - fd(:ilen(fd)),'.' - write(jplot,'(2a)') '% To change the dimensions use the LaTeX',& - ' \\unitlength=number command.' - write(jplot,'(a)') '% The default dimensions fit an A4 page.' - write(jplot,'(80(1h%))') - write(jplot,'(a,i5,a)') '\\begin{picture}(1,1)(0,',iylen,')' - ycur=ylen+ybox - do icut=ncut,1,-1 - xcur=xlen*(icut-1) - write(jplot,'(a,f6.1,a,f6.1,a,f4.2,a)') & - ' \\put(',xcur,',',ycur,'){',rcutoff(icut),' \\AA}' - enddo ! icut - xcur=0.0 - xdraw=xcur+xbox - nnc=ncur(1) - write(jplot,'(a,i3,a)') '% Begin cut-off',1,'.' - do j=1,nnc - ydraw=y(j,1) - ycur=ydraw-0.5*ybox - ideltx=deltx - write(jplot,'(4(a,f6.1),a,i3,a)') & - ' \\put(',xcur,',',ycur,'){\\framebox(',xbox,',',ybox,'){',& - itree(j,1),'}}' - write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & - ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,& - ',',0,'){',deltx,'}}' - enddo ! j - do icut=2,ncut - write(jplot,'(a,i3,a)') '% Begin cut-off',icut,'.' - xcur=xlen*(icut-1) - xdraw=xcur-deltx -!d print *,'icut=',icut,' xlen=',xlen,' deltx=',deltx, -!d & ' xcur=',xcur,' xdraw=',xdraw - nnc=ncur(icut) - do j=1,ncur(icut-1) - ydraw=y(ifirst(j,icut-1),icut) - delty=y(ilast(j,icut-1),icut)-y(ifirst(j,icut-1),icut) - idelty=delty - write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & - ' \\put(',xdraw,',',ydraw,'){\\line(',0,& - ',',idelty,'){',delty,'}}' - enddo - do j=1,nnc - xcur=xlen*(icut-1) - xdraw=xcur-deltx - ydraw=y(j,icut) - ycur=ydraw-0.5*ybox - ideltx=deltx - write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & - ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,& - ',',0,'){',deltx,'}}' - write(jplot,'(4(a,f6.1),a,i3,a)') & - ' \\put(',xcur,',',ycur,'){\\framebox(',xbox,',',ybox,'){',& - itree(j,icut),'}}' - if (icut.lt.ncut) then - xdraw=xcur+xbox - write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)') & - ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,& - ',',0,'){',deltx,'}}' - endif - enddo ! j - enddo ! icut - write(jplot,'(a)') '\\end{picture}' - RETURN - END SUBROUTINE PLOTREE -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ - end module tracking diff --git a/source/unres/CMakeLists.txt b/source/unres/CMakeLists.txt index d83102e..7c5136b 100644 --- a/source/unres/CMakeLists.txt +++ b/source/unres/CMakeLists.txt @@ -8,53 +8,53 @@ enable_language (Fortran) # Set source file lists for different compilation flags #================================ set(UNRES_MD_SRC0 - data/names.f90 - data/io_units.f90 - data/calc_data.f90 - data/compare_data.f90 - data/control_data.f90 - data/CSA_data.f90 - data/energy_data.f90 - data/geometry_data.f90 - data/map_data.f90 - data/MCM_data.f90 - data/MD_data.f90 - data/MPI_data.f90 - data/REMD_data.f90 - data/comm_local.f90 - prng_32.f90 - math.f90 - random.f90 - geometry.f90 - io_base.f90 - energy.f90 - check_bond.f90 + data/names.F90 + data/io_units.F90 + data/calc_data.F90 + data/compare_data.F90 + data/control_data.F90 + data/CSA_data.F90 + data/energy_data.F90 + data/geometry_data.F90 + data/map_data.F90 + data/MCM_data.F90 + data/MD_data.F90 + data/MPI_data.F90 + data/REMD_data.F90 + data/comm_local.F90 + prng_32.F90 + math.F90 + random.F90 + geometry.F90 + io_base.F90 + energy.F90 + check_bond.F90 control.F90 - MPI.f90 - regularize.f90 + MPI.F90 + regularize.F90 compare.F90 - map.f90 - muca_md.f90 - MCM_MD.f90 - io.f90 - MREMD.f90 - CSA.f90 - unres.f90 - MD.f90 - REMD.f90 + map.F90 + muca_md.F90 + MCM_MD.F90 + io.F90 + MREMD.F90 + CSA.F90 + unres.F90 + MD.F90 + REMD.F90 ) set(UNRES_MD_SRC1 - data/minim_data.f90 + data/minim_data.F90 ) set(UNRES_MD_SRC2 - minim.f90 - md_calc.f90 + minim.F90 + md_calc.F90 ) set(UNRES_MD_SRC3 - io_config.f90 + io_config.F90 ) @@ -163,15 +163,15 @@ else(UNRES_WITH_MPI) endif(UNRES_WITH_MPI) #========================================= -# cinfo.f90 workaround for cmake +# cinfo.F90 workaround for cmake #========================================= # get the current date TODAY(DATE) -# generate cinfo.f90 +# generate cinfo.F90 -set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90") +set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.F90") FILE(WRITE ${CINFO} -"! CMake generated file cinfo.f90 +"! CMake generated file cinfo.F90 subroutine cinfo use io_units write(iout,*)'++++ Compile info ++++' @@ -192,12 +192,12 @@ FILE(APPEND ${CINFO} end ") # add include path -set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90 PROPERTY COMPILE_FLAGS "${FFLAGS} -I${CMAKE_CURRENT_SOURCE_DIR}") +set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.F90 PROPERTY COMPILE_FLAGS "${FFLAGS} -I${CMAKE_CURRENT_SOURCE_DIR}") #========================================= # Set full unres MD sources #========================================= -set(UNRES_MD_SRCS ${UNRES_MD_SRC0} ${UNRES_MD_SRC1} ${UNRES_MD_SRC2} ${UNRES_MD_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90 ) +set(UNRES_MD_SRCS ${UNRES_MD_SRC0} ${UNRES_MD_SRC1} ${UNRES_MD_SRC2} ${UNRES_MD_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.F90 ) set_property(SOURCE ${UNRES_MD_SRCS} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) #========================================= @@ -386,18 +386,18 @@ export PREFIX=$1 UNRES_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_BIN} #----------------------------------------------------------------------------- DD=${CMAKE_SOURCE_DIR}/PARAM -export BONDPAR=$DD/bond_AM1_ext.parm -export THETPAR=$DD/theta_abinitio_old_ext.parm -export THETPARPDB=$DD/thetaml_ext.5parm -export ROTPARPDB=$DD/scgauss_ext.parm -export ROTPAR=$DD/rotamers_AM1_aura_ext.10022007.parm -export TORPAR=$DD/torsion_631Gdp_old_ext.parm -export TORDPAR=$DD/torsion_double_631Gdp_old_ext.parm -export ELEPAR=$DD/electr_631Gdp_ext.parm -export SIDEPAR=$DD/scinter_GB_ext.parm -export FOURIER=$DD/fourier_opt_ext.parm.1igd_hc_iter3_3 -export SCCORPAR=$DD/sccor_am1_pawel_ext.dat -export SCPPAR=$DD/scp_ext.parm +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 #----------------------------------------------------------------------------- echo CTEST_FULL_OUTPUT @@ -442,18 +442,18 @@ export PREFIX=$1 UNRES_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_BIN} #----------------------------------------------------------------------------- DD=${CMAKE_SOURCE_DIR}/PARAM -export BONDPAR=$DD/bond_AM1_ext.parm -export THETPAR=$DD/theta_abinitio_old_ext.parm -export THETPARPDB=$DD/thetaml_ext.5parm -export ROTPARPDB=$DD/scgauss_ext.parm -export ROTPAR=$DD/rotamers_AM1_aura_ext.10022007.parm -export TORPAR=$DD/torsion_631Gdp_old_ext.parm -export TORDPAR=$DD/torsion_double_631Gdp_old_ext.parm -export ELEPAR=$DD/electr_631Gdp_ext.parm -export SIDEPAR=$DD/scinter_GB_ext.parm -export FOURIER=$DD/fourier_opt_ext.parm.1igd_hc_iter3_3 -export SCCORPAR=$DD/sccor_am1_pawel_ext.dat -export SCPPAR=$DD/scp_ext.parm +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 #----------------------------------------------------------------------------- echo CTEST_FULL_OUTPUT diff --git a/source/unres/CSA.F90 b/source/unres/CSA.F90 new file mode 100644 index 0000000..66b98ee --- /dev/null +++ b/source/unres/CSA.F90 @@ -0,0 +1,5321 @@ + module csa +!----------------------------------------------------------------------------- + use io_units + use names + use math + use random + use geometry_data, only: nres,rad2deg + use geometry + use energy + use MPI_ + use csa_data + use compare + use io_config + + implicit none +!----------------------------------------------------------------------------- +! commom.bank +! common/varin/ +! real(kind=8),dimension(:,:,:,:),allocatable :: dihang_in !(mxang,maxres,mxch,mxio) + integer,dimension(:),allocatable :: nss_in !(mxio) + integer,dimension(:,:),allocatable :: iss_in,jss_in !(maxss,mxio) +! common/minvar/ + real(kind=8),dimension(:,:,:,:),allocatable :: dihang !(mxang,maxres,mxch,mxio) + real(kind=8),dimension(:),allocatable :: etot!,rmsn,pncn !(mxio) + integer,dimension(:),allocatable :: nss_out !(mxio) + integer,dimension(:,:),allocatable ::iss_out,jss_out !(maxss,mxio) +! common/bank/ +! real(kind=8),dimension(:,:,:,:),allocatable :: bvar !(mxang,maxres,mxch,mxio) +! real(kind=8),dimension(:),allocatable :: bene,rene,& +! brmsn,rrmsn,bpncn,rpncn !(mxio) + integer,dimension(:),allocatable :: is,jbank !(mxio) + real(kind=8) :: avedif,difmin,ebmin,ebmax,ebmaxt!,& +! dele,difcut,cutdif,rmscut,pnccut + real(kind=8),dimension(:,:),allocatable :: dij !(mxio,mxio) +! common/bank_disulfid/ +! common/mvstat/ + integer,dimension(:),allocatable :: movenx,movernx !(mxio) + integer,dimension(:,:),allocatable :: nstatnx,nstatnx_tot !(0:mxmv,3) + integer,dimension(:,:),allocatable :: indb !(mxio,9) + integer,dimension(:,:),allocatable :: parent !(3,mxio) +! common/send2/ + integer,dimension(:),allocatable :: isend2 !(mxio) + integer,dimension(:,:),allocatable :: iff_in !(maxres,mxio2) + integer,dimension(:,:,:,:),allocatable :: dihang_in2 !(mxang,maxres,mxch,mxio2) + integer,dimension(:,:),allocatable :: idata !(5,mxio) +!----------------------------------------------------------------------------- +! common.csa +! integer :: irestart,ndiff +! common/alphaa/ + integer,dimension(:),allocatable :: ngroup !(mxgr) + integer,dimension(:,:,:),allocatable :: igroup !(3,mxang,mxgr) + integer :: ntotgr!,numch +! common/csa_input/ +! common/dih_control/ +! real(kind=8) :: rdih_bias + logical :: ldih_bias +!----------------------------------------------------------------------------- +! common.distfit +! COMMON /frag/ + integer,dimension(:,:),allocatable :: bvar_frag !(mxio,6) + integer,dimension(:,:),allocatable :: hvar_frag,lvar_frag,svar_frag !(mxio,3) + integer,dimension(:,:),allocatable :: avar_frag !(mxio,5) +!----------------------------------------------------------------------------- +! commom.hairpin +! common /spinka/ + integer :: nharp_tot + integer,dimension(:),allocatable :: nharp_seed,nharp_use !(max_seed) + integer,dimension(:,:,:),allocatable :: iharp_seed !(4,maxres/3,max_seed) + integer,dimension(:,:,:),allocatable :: iharp_use !(0:4,maxres/3,max_seed) +!----------------------------------------------------------------------------- +! Maximum number of moves (n1-n8) + integer,parameter :: mxmv=18 +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! bank.F +!----------------------------------------------------------------------------- + subroutine refresh_bank(ntrial) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.CONTROL' + character :: chacc + integer :: iaccn,ntrial + real(kind=8) :: l_diff(mxio),denep + integer :: i,j,n,m,i1,idmin + real(kind=8) :: del_ene + + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + +! loop over all newly obtained conformations + do n=1,ntrial + chacc=' ' + iaccn=0 + nstatnx(movernx(n),1)=nstatnx(movernx(n),1)+1 +!ccccccccccccccccccccccccccccccccccccccccccc +!jlee + if(iref.ne.0) then + if(rmsn(n).gt.rmscut.or.pncn(n).lt.pnccut) goto 100 + endif +!jlee + if(etot(n).gt.ebmax) goto 100 +! Find the conformation closest to the conformation n in the bank + difmin=9.d9 + do m=1,nbank + call get_diff12(dihang(1,1,1,n),bvar(1,1,1,m),l_diff(m)) + if(l_diff(m).lt.difmin) then + difmin=l_diff(m) + idmin=m + endif + enddo + + if(difmin.lt.cutdif) then +! n is redundant to idmin + if(etot(n).lt.bene(idmin)) then + if(etot(n).lt.bene(idmin)-0.01d0) then + ibank(idmin)=0 + jbank(idmin)=0 + endif + denep=bene(idmin)-etot(n) + call replace_bvar(idmin,n) +!rc Update dij + do i1=1,nbank + if (i1.ne.idmin) then + dij(i1,idmin)=l_diff(i1) + dij(idmin,i1)=l_diff(i1) + endif + enddo + chacc='c' + iaccn=idmin + nstatnx(movernx(n),2)=nstatnx(movernx(n),2)+1 + if(idmin.eq.ibmax) call find_max + endif + else +! got new conformation + del_ene=0.0d0 + if(ebmax-ebmin.gt.del_ene) then + denep=ebmax-etot(n) + call replace_bvar(ibmax,n) +!rc Update dij + do i1=1,nbank + if (i1.ne.ibmax) then + dij(i1,ibmax)=l_diff(i1) + dij(ibmax,i1)=l_diff(i1) + endif + enddo + chacc='f' + iaccn=ibmax + nstatnx(movernx(n),3)=nstatnx(movernx(n),3)+1 + ibank(ibmax)=0 + jbank(ibmax)=0 + call find_max + else + if(del_ene.lt.0.0001) then + write (iout,*) 'ERROR in refresh_bank: ' + write (iout,*) 'ebmax: ',ebmax + write (iout,*) 'ebmin: ',ebmin + write (iout,*) 'del_ene: ',del_ene +!rc call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif +!jp nbmax is never defined so condition below is always false +! if(nbank.lt.nbmax) then +! nbank=nbank+1 +! call replace_bvar(nbank,n) +! ibank(nbank)=0 +! jbank(nbank)=0 +! else + call replace_bvar(ibmax,n) + ibank(ibmax)=0 + jbank(ibmax)=0 + call find_max +! endif + endif + endif +!ccccccccccccccccccccccccccccccccccccccccccc + 100 continue + if (iaccn.eq.0) then + if (iref.eq.0) then + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5)') & + indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& + indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9) + else + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5,0pf4.1,a5,f3.0)') & + indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& + indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9),& + ' rms ',rmsn(n),' %NC ',pncn(n)*100 + endif + else + if (iref.eq.0) then + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,1x,a1,i4,0pf8.1,0pf8.1)') & + indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& + indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9),& + chacc,iaccn,difmin,denep + else + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5,0pf4.1,a5,f3.0,1x,a1,i4,0pf8.1,0pf8.1)') & + indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& + indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9),& + ' rms ',rmsn(n),' %NC ',pncn(n)*100,& + chacc,iaccn,difmin,denep + endif + endif + enddo +! end of loop over all newly obtained conformations + do i=0,mxmv + if(nstatnx(i,1).ne.0) then + if (i.le.9) then + write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') & + '## N',i,' total=',nstatnx(i,1),& + ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& + ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) + else + write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') & + '##N',i,' total=',nstatnx(i,1),& + ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& + ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) + endif + else + if (i.le.9) then + write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') & + '## N',i,' total=',nstatnx(i,1),& + ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& + ' %acc',0.0 + else + write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') & + '##N',i,' total=',nstatnx(i,1),& + ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& + ' %acc',0.0 + endif + endif + enddo + call flush(iout) +!rc Update dij +!rc moved up, saves some get_diff12 calls +!rc +!rc do i1=1,nbank-1 +!rc do i2=i1+1,nbank +!rc if(jbank(i1).eq.0.or.jbank(i2).eq.0) then +!rc call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) +!rc dij(i1,i2)=diff +!rc dij(i2,i1)=diff +!rc endif +!rc enddo +!rc enddo + + do i=1,nbank + jbank(i)=1 + enddo + + return + end subroutine refresh_bank +!----------------------------------------------------------------------------- + subroutine replace_bvar(iold,inew) + + use control_data, only: vdisulf + use energy_data, only: ns,iss +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.CONTROL' +! include 'COMMON.SBRIDGE' + integer :: iold,inew,ierror,ierrcode,i,j,k + + if (iold.gt.mxio .or. iold.lt.1 .or. inew.gt.mxio .or. inew.lt.1) & + then + write (iout,*) 'Dimension ERROR in REPLACE_BVAR: IOLD',iold,& + ' INEW',inew + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + bvar(i,j,k,iold)=dihang(i,j,k,inew) + enddo + enddo + enddo + bene(iold)=etot(inew) + brmsn(iold)=rmsn(inew) + bpncn(iold)=pncn(inew) + + if(bene(iold).lt.ebmin) then + ebmin=bene(iold) + ibmin=iold + endif + + if(vdisulf) then + bvar_nss(iold)=nss_out(inew) +!d write(iout,*) 'SS BANK',iold,bvar_nss(iold) + do i=1,bvar_nss(iold) + bvar_ss(1,i,iold)=iss_out(i,inew) + bvar_ss(2,i,iold)=jss_out(i,inew) +!d write(iout,*) 'SS',bvar_ss(1,i,iold)-nres, +!d & bvar_ss(2,i,iold)-nres + enddo + + bvar_ns(iold)=ns-2*bvar_nss(iold) +!d write(iout,*) 'CYS #free ', bvar_ns(iold) + k=0 + do i=1,ns + j=1 + do while( iss(i).ne.iss_out(j,inew)-nres .and. & + iss(i).ne.jss_out(j,inew)-nres .and. & + j.le.nss_out(inew)) + j=j+1 + enddo + if (j.gt.nss_out(inew)) then + k=k+1 + bvar_s(k,iold)=iss(i) + endif + enddo +!d write(iout,*) 'CYS free',(bvar_s(k,iold),k=1,bvar_ns(iold)) + endif + + return + end subroutine replace_bvar +!----------------------------------------------------------------------------- + subroutine save_is(ind) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' + integer :: ind,i,j,k,index,ierror,ierrcode + + index=nbank+ind +! print *, "nbank,ind,index,is(ind) ",nbank,ind,index,is(ind) + if (index.gt.mxio .or. index.lt.1 .or. & + is(ind).gt.mxio .or. is(ind).lt.1) then + write (iout,*) 'Dimension ERROR in SAVE_IS: INDEX',index,& + ' IND',ind,' IS',is(ind) + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + bvar(i,j,k,index)=bvar(i,j,k,is(ind)) + enddo + enddo + enddo + bene(index)=bene(is(ind)) + ibank(is(ind))=1 + + return + end subroutine save_is +!----------------------------------------------------------------------------- + subroutine select_is(n,ifar,idum) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer,dimension(mxio) :: itag + real(kind=8),dimension(mxio) :: adiff + integer :: n,ifar,idum,i,iusesv,imade + + iuse=0 + do i=1,nbank + if(ibank(i).eq.0) then + iuse=iuse+1 + itag(iuse)=i + endif + enddo + iusesv=iuse + + if(iuse.eq.0) then + icycle=icycle+1 + do i=1,nbank + if(ibank(i).eq.2) then + ibank(i)=1 + else + ibank(i)=0 + endif + enddo + imade=0 + call get_is(idum,ifar,n,imade,0) +!test3 call get_is_max(idum,ifar,n,imade,0) + else if(iuse.eq.n) then + do i=1,iuse + is(i)=itag(i) + call save_is(i) + enddo + else if(iuse.lt.n) then +! if(icycle.eq.0) then +! do i=1,n +! ind=mod(i-1,iuse)+1 +! is(i)=itag(ind) +! call save_is(i) +! enddo +! else +! endif + do i=1,iuse + is(i)=itag(i) + call save_is(i) + enddo + imade=iuse +! call get_is_ran(idum,n,imade,1) + call get_is(idum,ifar,n,imade,1) +!test3 call get_is_max(idum,ifar,n,imade,1) +! if(iusesv.le.n/10) then + if(iusesv.le.0) then + icycle=icycle+1 + do i=1,nbank +! if(ibank(i).eq.2) then +! ibank(i)=1 + if(ibank(i).ge.2) then + ibank(i)=ibank(i)-1 + else + ibank(i)=0 + endif + enddo + endif + else + imade=0 + call get_is(idum,ifar,n,imade,0) +!test3 call get_is_max(idum,ifar,n,imade,0) + endif + iuse=iusesv + + return + end subroutine select_is +!----------------------------------------------------------------------------- + subroutine get_is_ran(idum,n,imade,k) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! real(kind=4) :: ran1,ran2 + integer,dimension(mxio) :: itag + real(kind=8),dimension(mxio) :: adiff + integer :: idum,n,imade,k,j,i,iran + + do j=imade+1,n + iuse=0 + do i=1,nbank + if(ibank(i).eq.k) then + iuse=iuse+1 + itag(iuse)=i + endif + enddo + iran=iuse* ran1(idum)+1 + is(j)=itag(iran) + call save_is(j) + enddo + + return + end subroutine get_is_ran +!----------------------------------------------------------------------------- + subroutine get_is(idum,ifar,n,imade,k) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! real(kind=4) :: ran1,ran2 + integer,dimension(mxio) :: itag + real(kind=8),dimension(mxio) :: adiff + integer :: idum,ifar,n,imade,k,i,iran + + iuse=0 + do i=1,nbank + if(ibank(i).eq.k) then + iuse=iuse+1 + itag(iuse)=i + endif + enddo + iran=iuse* ran1(idum)+1 + imade=imade+1 + is(imade)=itag(iran) + call save_is(imade) + + do i=imade+1,ifar-1 + if(icycle.eq.-1) then + call select_iseed_max(i,k) + else + call select_iseed_min(i,k) +!test4 call select_iseed_max(i,k) + endif + call save_is(i) + enddo + + do i=ifar,n + call select_iseed_far(i,k) + call save_is(i) + enddo + + return + end subroutine get_is +!----------------------------------------------------------------------------- + subroutine select_iseed_max(imade1,ik) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer,dimension(mxio) :: itag + real(kind=8),dimension(mxio) :: adiff + integer :: imade1,ik,i,n,imade,m,itagi + real(kind=8) :: difmax,diff,emax,benei,diffmn + + iuse=0 + avedif=0.d0 + difmax=0.d0 + do n=1,nbank + if(ibank(n).eq.ik) then + iuse=iuse+1 + diffmn=9.d190 + do imade=1,imade1-1 +! m=nbank+imade +! call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) + m=is(imade) + diff=dij(n,m) + if(diff.lt.diffmn) diffmn=diff + enddo + if(diffmn.gt.difmax) difmax=diffmn + adiff(iuse)=diffmn + itag(iuse)=n + avedif=avedif+diffmn + endif + enddo + + avedif=avedif/iuse +! avedif=(avedif+difmax)/2 + emax=-9.d190 + do i=1,iuse + if(adiff(i).ge.avedif) then + itagi=itag(i) + benei=bene(itagi) + if(benei.gt.emax) then + emax=benei + is(imade1)=itagi + endif + endif + enddo + + if(ik.eq.0) iuse=iuse-1 + + return + end subroutine select_iseed_max +!----------------------------------------------------------------------------- + subroutine select_iseed_min(imade1,ik) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer,dimension(mxio) :: itag + real(kind=8),dimension(mxio) :: adiff + integer :: imade1,ik,n,imade,m,i,itagi + real(kind=8) :: difmax,diff,diffmn,emin,benei + + iuse=0 + avedif=0.d0 + difmax=0.d0 + do n=1,nbank + if(ibank(n).eq.ik) then + iuse=iuse+1 + diffmn=9.d190 + do imade=1,imade1-1 +! m=nbank+imade +! call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) + m=is(imade) + diff=dij(n,m) + if(diff.lt.diffmn) diffmn=diff + enddo + if(diffmn.gt.difmax) difmax=diffmn + adiff(iuse)=diffmn + itag(iuse)=n + avedif=avedif+diffmn + endif + enddo + + avedif=avedif/iuse +! avedif=(avedif+difmax)/2 + emin=9.d190 + do i=1,iuse +! print *,"i, adiff(i),avedif : ",i,adiff(i),avedif + if(adiff(i).ge.avedif) then + itagi=itag(i) + benei=bene(itagi) +! print *,"i, benei,emin : ",i,benei,emin + if(benei.lt.emin) then + emin=benei + is(imade1)=itagi + endif + endif + enddo + + if(ik.eq.0) iuse=iuse-1 + +! print *, "exiting select_iseed_min",is(imade1) + + return + end subroutine select_iseed_min +!----------------------------------------------------------------------------- + subroutine select_iseed_far(imade1,ik) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer :: imade1,ik,n,imade,m + real(kind=8) :: dmax,diffmn,diff + + dmax=-9.d190 + do n=1,nbank + if(ibank(n).eq.ik) then + diffmn=9.d190 + do imade=1,imade1-1 +! m=nbank+imade +! call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) + m=is(imade) + diff=dij(n,m) + if(diff.lt.diffmn) diffmn=diff + enddo + endif + if(diffmn.gt.dmax) then + dmax=diffmn + is(imade1)=n + endif + enddo + + return + end subroutine select_iseed_far +!----------------------------------------------------------------------------- + subroutine find_min + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer :: i + real(kind=8) :: benei + + ebmin=9.d190 + + do i=1,nbank + benei=bene(i) + if(benei.lt.ebmin) then + ebmin=benei + ibmin=i + endif + enddo + + return + end subroutine find_min +!----------------------------------------------------------------------------- + subroutine find_max + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer :: i + real(kind=8) :: benei + + ebmax=-9.d190 + + do i=1,nbank + benei=bene(i) + if(benei.gt.ebmax) then + ebmax=benei + ibmax=i + endif + enddo + + return + end subroutine find_max +!----------------------------------------------------------------------------- + subroutine get_diff + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer :: i,i1,i2 + real(kind=8) :: tdiff,difmin,diff + + tdiff=0.d0 + difmin=9.d190 + do i1=1,nbank-1 + do i2=i1+1,nbank + if(jbank(i1).eq.0.or.jbank(i2).eq.0) then + call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) + dij(i1,i2)=diff + dij(i2,i1)=diff + else + diff=dij(i1,i2) + endif + tdiff=tdiff+diff + if(diff.lt.difmin) difmin=diff + enddo + dij(i1,i1)=0.0 + enddo + + do i=1,nbank + jbank(i)=1 + enddo + + avedif=tdiff/nbank/(nbank-1)*2 + + return + end subroutine get_diff +!----------------------------------------------------------------------------- + subroutine estimate_cutdif(adif,xct,cutdifr) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer :: nexp + real(kind=8) :: adif,xct,cutdifr,ctdif1,exponent + + ctdif1=adif/cut2 + + exponent = cutdifr*cut1/adif + exponent = dlog(exponent)/dlog(xct) + + nexp=exponent+0.25 + cutdif= adif/cut1*xct**nexp + if(cutdif.lt.ctdif1) cutdif=ctdif1 + + return + end subroutine estimate_cutdif +!----------------------------------------------------------------------------- + subroutine get_is_max(idum,ifar,n,imade,k) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' + integer :: idum,ifar,n,imade,k,i,j + real(kind=8) :: emax + + do i=imade+1,n + emax=-9.d190 + do j=1,nbank + if(ibank(j).eq.k .and. bene(j).gt.emax) then + emax=bene(j) + is(i)=j + endif + enddo + call save_is(i) + enddo + + return + end subroutine get_is_max +!----------------------------------------------------------------------------- +! csa.f +!----------------------------------------------------------------------------- + subroutine make_array + + use energy_data, only: itype +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.CSA' + integer :: k,j,i,indg +!cccccccccccccccccccccccc +! Level-2: group +!cccccccccccccccccccccccc + + indg=0 + do k=1,numch +!cccccccccccccccccccccccccccccccccccccccc +! Groups the THETAs and the GAMMAs + do j=2,nres-1 + indg=indg+1 + if (j.lt.nres-1) then + ngroup(indg)=2 + else + ngroup(indg)=1 + endif + do i=1,ngroup(indg) + igroup(1,i,indg)=i + igroup(2,i,indg)=j + igroup(3,i,indg)=k + enddo + enddo +!cccccccccccccccccccccccccccccccccccccccc + enddo +! Groups the ALPHAs and the BETAs + do k=1,numch + do j=2,nres-1 + if(itype(j).ne.10) then + indg=indg+1 + ngroup(indg)=2 + do i=1,ngroup(indg) + igroup(1,i,indg)=i+2 + igroup(2,i,indg)=j + igroup(3,i,indg)=k + enddo + endif + enddo + enddo + + ntotgr=indg + write(iout,*) + write(iout,*) "# of groups: ",ntotgr + do i=1,ntotgr + write(iout,41) i,ngroup(i),((igroup(k,j,i),k=1,3),j=1,ngroup(i)) + enddo +! close(iout) + + 40 format(i3,3x,3i3) + 41 format(2i3,3x,6(3i3,2x)) + + return + end subroutine make_array +!----------------------------------------------------------------------------- + subroutine make_ranvar(n,m,idum) + + use geometry_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.BANK' + integer :: n,m,j,idum,itrial,jeden + +! al m=0 + print *,'HOHOHOHO Make_RanVar!!!!!',n,m + itrial=0 + do while(m.lt.n .and. itrial.le.10000) + itrial=itrial+1 + jeden=1 + call gen_rand_conf(jeden,*10) +! call intout + m=m+1 + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + enddo + dihang_in(2,nres-1,1,m)=0.0d0 + goto 20 + 10 write (iout,*) 'Failed to generate conformation #',m+1,& + ' itrial=',itrial + 20 continue + enddo + print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial + + return + end subroutine make_ranvar +!----------------------------------------------------------------------------- + subroutine make_ranvar_reg(n,idum) + + use geometry_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.BANK' +! include 'COMMON.GEO' + integer :: n,idum,j,m,itrial,jeden + + m=0 + print *,'HOHOHOHO Make_RanVar!!!!!' + itrial=0 + do while(m.lt.n .and. itrial.le.10000) + itrial=itrial+1 + jeden=1 + call gen_rand_conf(jeden,*10) +! call intout + m=m+1 + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + if(m.le.n*0.1) then + dihang_in(1,j,1,m)=90.0*deg2rad + dihang_in(2,j,1,m)=50.0*deg2rad + endif + enddo + dihang_in(2,nres-1,1,m)=0.0d0 + goto 20 + 10 write (iout,*) 'Failed to generate conformation #',m+1,& + ' itrial=',itrial + 20 continue + enddo + print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial + + return + end subroutine make_ranvar_reg +!----------------------------------------------------------------------------- +! diff12.f +!----------------------------------------------------------------------------- + subroutine get_diff12(aarray,barray,diff) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + integer :: k,j,i + real(kind=8),dimension(mxang,nres,mxch) :: aarray,barray !(mxang,maxres,mxch) + real(kind=8) :: diff,dif + + diff=0.d0 + do k=1,numch + do j=2,nres-1 +! do i=1,4 +! do i=1,2 + do i=1,ndiff + dif=rad2deg*dabs(aarray(i,j,k)-barray(i,j,k)) + if(dif.gt.180.) dif=360.-dif + if (dif.gt.diffcut) diff=diff+dif + enddo + enddo + enddo + + return + end subroutine get_diff12 +!----------------------------------------------------------------------------- +! indexx.f +!----------------------------------------------------------------------------- + subroutine indexx(n,arr,indx) + +! implicit real*8 (a-h,o-z) + INTEGER :: n,indx(n) + REAL(kind=8) :: arr(n) +! PARAMETER (M=7,NSTACK=50) + integer,PARAMETER :: M=7,NSTACK=500 + INTEGER :: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) + REAL(kind=8) :: a + + do 11 j=1,n + indx(j)=j +11 continue + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do 13 j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do 12 i=j-1,1,-1 + if(arr(indx(i)).le.a)goto 2 + indx(i+1)=indx(i) +12 continue + i=0 +2 indx(i+1)=indxt +13 continue + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l+1)).gt.arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)).gt.arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)).gt.arr(indx(l)))then + itemp=indx(l+1) + indx(l+1)=indx(l) + indx(l)=itemp + endif + i=l+1 + j=ir + indxt=indx(l) + a=arr(indxt) +3 continue + i=i+1 + if(arr(indx(i)).lt.a)goto 3 +4 continue + j=j-1 + if(arr(indx(j)).gt.a)goto 4 + if(j.lt.i)goto 5 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + goto 3 +5 indx(l)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + end subroutine indexx +! (C) Copr. 1986-92 Numerical Recipes Software *11915aZ%. +!----------------------------------------------------------------------------- +! minim_jlee.F +!----------------------------------------------------------------------------- + subroutine minim_jlee + + use minim_data + use MPI_data + use energy_data + use compare_data + use control_data + use geometry_data, only: nvar,nphi + use geometry, only:dist + use energy, only:fdum + use control, only:init_int_table + use minimm, only:sumsl,deflt +! controls minimization and sorting routines +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.MINIM' +! include 'COMMON.CONTROL' + include 'mpif.h' + integer,parameter :: liv=60 + integer :: lv +! external func,gradient!,fdum !use minim & energy +! real(kind=4) :: ran1,ran2,ran3 +! include 'COMMON.SETUP' +! include 'COMMON.GEO' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.DISTFIT' +! include 'COMMON.CHAIN' + integer,dimension(mpi_status_size) :: muster + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: erg + real(kind=8),dimension(6*nres) :: var2 !(maxvar) (maxvar=6*maxres) + integer,dimension(nres) :: iffr !(maxres) + integer,dimension((nres-1)*(nres-2)/2) :: ihpbt,jhpbt !(maxdim) (maxdim=(maxres-1)*(maxres-2)/2) + real(kind=8),dimension(6*nres) :: d,garbage !(maxvar) (maxvar=6*maxres) +!el real(kind=8),dimension(1:lv+1) :: v + real(kind=8) :: energia(0:n_ene),time0s,time1s + integer,dimension(9) :: indx + integer,dimension(12) :: info + integer,dimension(liv) :: iv + integer :: idum(1) + real(kind=8) :: rdum(1) + integer,dimension(2,12*nres) :: icont_ !(2,maxcont)(maxcont=12*maxres) + logical :: fail !check_var, + integer :: iloop(2) +!el common /przechowalnia/ v + integer :: i,j,ierr,n,nfun,nft_sc,nf,ierror,ierrcode + real(kind=8) :: rad,eee,etot !,fdum +!el from subroutine parmread +! Define the constants of the disulfide bridge +! Old arbitrary potential + real(kind=8),parameter :: dbr=4.20D0 + real(kind=8),parameter :: fbr=3.30D0 +!----------------- + lv=77+(6*nres)*(6*nres+17)/2 !77+maxvar*(maxvar+17)/2 (maxvar=6*maxres) + data rad /1.745329252d-2/ +! receive # of start +! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, +! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf + if (.not. allocated(v)) allocate(v(1:lv)) + nhpb0=nhpb + 10 continue + time0s=MPI_WTIME() +! print *, 'MINIM_JLEE: ',me,' is waiting' + call mpi_recv(info,12,mpi_integer,king,idint,CG_COMM,& + muster,ierr) + time1s=MPI_WTIME() + write (iout,'(a12,f10.4,a4)')'Waiting for ',time1s-time0s,' sec' + call flush(iout) + n=info(1) +! print *, 'MINIM_JLEE: ',me,' received: ',n + +!rc if (ierr.ne.0) go to 100 +! if # = 0, return + if (n.eq.0) then + write (iout,*) 'Finishing minim_jlee - signal',n,' from master' + call flush(iout) + return + endif + + nfun=0 + IF (n.lt.0) THEN + call mpi_recv(var,nvar,mpi_double_precision,& + king,idreal,CG_COMM,muster,ierr) + call mpi_recv(iffr,nres,mpi_integer,& + king,idint,CG_COMM,muster,ierr) + call mpi_recv(var2,nvar,mpi_double_precision,& + king,idreal,CG_COMM,muster,ierr) + ELSE +! receive initial values of variables + call mpi_recv(var,nvar,mpi_double_precision,& + king,idreal,CG_COMM,muster,ierr) +!rc if (ierr.ne.0) go to 100 + ENDIF + + if(vdisulf.and.info(2).ne.-1) then + if(info(4).ne.0)then + call mpi_recv(ihpbt,info(4),mpi_integer,& + king,idint,CG_COMM,muster,ierr) + call mpi_recv(jhpbt,info(4),mpi_integer,& + king,idint,CG_COMM,muster,ierr) + endif + endif + + IF (n.lt.0) THEN + n=-n + nhpb=nhpb0 + link_start=1 + link_end=nhpb + call init_int_table + call contact_cp(var,var2,iffr,nfun,n) + ENDIF + + if(vdisulf.and.info(2).ne.-1) then + nss=0 + if(info(4).ne.0)then +!d write(iout,*) 'SS=',info(4),'N=',info(1),'IT=',info(2) + call var_to_geom(nvar,var) + call chainbuild + do i=1,info(4) + if (dist(ihpbt(i),jhpbt(i)).lt.7.0) then + nss=nss+1 + ihpb(nss)=ihpbt(i) + jhpb(nss)=jhpbt(i) +!d write(iout,*) 'SS mv=',info(3), +!d & ihpb(nss)-nres,jhpb(nss)-nres, +!d & dist(ihpb(nss),jhpb(nss)) + dhpb(nss)=dbr + forcon(nss)=fbr + else +!d write(iout,*) 'rm SS mv=',info(3), +!d & ihpbt(i)-nres,jhpbt(i)-nres,dist(ihpbt(i),jhpbt(i)) + endif + enddo + endif + nhpb=nss + link_start=1 + link_end=nhpb + call init_int_table + endif + + if (info(3).eq.14) then + write(iout,*) 'calling local_move',info(7),info(8) + call local_move_init(.false.) + call var_to_geom(nvar,var) + call local_move(info(7),info(8),20d0,50d0) + call geom_to_var(nvar,var) + endif + + + if (info(3).eq.16) then + write(iout,*) 'calling beta_slide',info(7),info(8),& + info(10), info(11), info(12) + call var_to_geom(nvar,var) + call beta_slide(info(7),info(8),info(10),info(11),info(12), & + nfun,n) + call geom_to_var(nvar,var) + endif + + + if (info(3).eq.17) then + write(iout,*) 'calling beta_zip',info(7),info(8) + call var_to_geom(nvar,var) + call beta_zip(info(7),info(8),nfun,n) + call geom_to_var(nvar,var) + endif + + +!rc overlap test + + if (overlapsc) then + + call var_to_geom(nvar,var) + call chainbuild + call etotal(energia) + nfun=nfun+1 + if (energia(1).eq.1.0d20) then + info(3)=-info(3) + write (iout,'(a,1pe14.5)')'#OVERLAP evdw=1d20',energia(1) + call overlap_sc(fail) + if(.not.fail) then + call geom_to_var(nvar,var) + call etotal(energia) + nfun=nfun+1 + write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) + else + v(10)=1.0d20 + iv(1)=-1 + goto 201 + endif + endif + endif + + if (searchsc) then + call var_to_geom(nvar,var) + call sc_move(2,nres-1,1,10d0,nft_sc,etot) + call geom_to_var(nvar,var) +!d write(iout,*) 'sc_move',nft_sc,etot + endif + + if (check_var(var,info)) then + v(10)=1.0d21 + iv(1)=6 + goto 201 + endif + + +!rc + +! write (iout,*) 'MINIM_JLEE: Processor',me,' nvar',nvar +! write (iout,'(8f10.4)') (var(i),i=1,nvar) +! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar +! write (*,'(8f10.4)') (var(i),i=1,nvar) + + do i=1,nvar + garbage(i)=var(i) + enddo + + call deflt(2,iv,liv,lv,v) +! 12 means fresh start, dont call deflt + iv(1)=12 +! max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +! max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +! controls output + iv(19)=2 +! selects output unit +!d iv(21)=iout + iv(21)=0 +! 1 means to print out result + iv(22)=0 +!d iv(22)=1 +! 1 means to print out summary stats + iv(23)=0 +! 1 means to print initial x and d + iv(24)=0 + +! if(me.eq.3.and.n.eq.255) then +! print *,' CHUJ: stoi' +! iv(21)=6 +! iv(22)=1 +! iv(23)=1 +! iv(24)=1 +! endif + +! min val for v(radfac) default is 0.1 + v(24)=0.1D0 +! max val for v(radfac) default is 4.0 + v(25)=2.0D0 +! v(25)=4.0D0 +! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +! the sumsl default is 0.1 + v(26)=0.1D0 +! false conv if (act fnctn decrease) .lt. v(34) +! the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +! absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +! relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +! controls initial step size + v(35)=1.0D-1 +! large vals of d correspond to small components of step + do i=1,nphi + d(i)=1.0D-1 + enddo + do i=nphi+1,nvar + d(i)=1.0D-1 + enddo +! minimize energy +! write (iout,*) 'Processor',me,' nvar',nvar +! write (iout,*) 'Variables BEFORE minimization:' +! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) + +! print *, 'MINIM_JLEE: ',me,' before SUMSL ' + + call func(nvar,var,nf,eee,idum,rdum,fdum) + nfun=nfun+1 + if(eee.ge.1.0d20) then +! print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +! print *,' energy before SUMSL =',eee +! print *,' aborting local minimization' + iv(1)=-1 + v(10)=eee + go to 201 + endif + +!t time0s=MPI_WTIME() + call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) +!t write(iout,*) 'sumsl time=',MPI_WTIME()-time0s,iv(7),v(10) +! print *, 'MINIM_JLEE: ',me,' after SUMSL ' + +! find which conformation was returned from sumsl + nfun=nfun+iv(7) +! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, +! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) +! if (iv(1).ne.4 .or. nf.le.1) then +! write (*,*) 'Processor',me,' something bad in SUMSL',iv(1),nf +! write (*,*) 'Initial Variables' +! write (*,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) +! write (*,*) 'Variables' +! write (*,'(8f10.4)') (rad2deg*var(i),i=1,nvar) +! write (*,*) 'Vector d' +! write (*,'(8f10.4)') (d(i),i=1,nvar) +! write (iout,*) 'Processor',me,' something bad in SUMSL', +! & iv(1),nf +! write (iout,*) 'Initial Variables' +! write (iout,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) +! write (iout,*) 'Variables' +! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) +! write (iout,*) 'Vector d' +! write (iout,'(8f10.4)') (d(i),i=1,nvar) +! endif +! if (nf.lt.iv(6)-1) then +! recalculate intra- and interchain energies +! call func(nvar,var,nf,v(10),iv,v,fdum) +! else if (nf.eq.iv(6)-1) then +! regenerate conformation +! call var_to_geom(nvar,var) +! call chainbuild +! endif +! change origin and axes to standard ECEPP format +! call var_to_geom(nvar,var) +! write (iout,*) 'MINIM_JLEE after minim: Processor',me,' nvar',nvar +! write (iout,'(8f10.4)') (var(i),i=1,nvar) +! write (iout,*) 'Energy:',v(10) +! send back output +! print *, 'MINIM_JLEE: ',me,' minimized: ',n + 201 continue + indx(1)=n +! return code: 6-gradient 9-number of ftn evaluation, etc + indx(2)=iv(1) +! total # of ftn evaluations (for iwf=0, it includes all minimizations). + indx(3)=nfun + indx(4)=info(2) + indx(5)=info(3) + indx(6)=nss + indx(7)=info(5) + indx(8)=info(6) + indx(9)=info(9) + call mpi_send(indx,9,mpi_integer,king,idint,CG_COMM,& + ierr) +! send back energies +! al & cc +! calculate contact order +#ifdef CO_BIAS + call contact(.false.,ncont,icont_,co) + erg(1)=v(10)-1.0d2*co +#else + erg(1)=v(10) +#endif + j=1 + call mpi_send(erg,j,mpi_double_precision,king,idreal,& + CG_COMM,ierr) +#ifdef CO_BIAS + call mpi_send(co,j,mpi_double_precision,king,idreal,& + CG_COMM,ierr) +#endif +! send back values of variables + call mpi_send(var,nvar,mpi_double_precision,& + king,idreal,CG_COMM,ierr) +! print * , 'MINIM_JLEE: Processor',me,' send erg and var ' + + if(vdisulf.and.info(2).ne.-1.and.nss.ne.0) then +!d call intout +!d call chainbuild +!d call etotal(energia(0)) +!d etot=energia(0) +!d call enerprint(energia(0)) + call mpi_send(ihpb,nss,mpi_integer,& + king,idint,CG_COMM,ierr) + call mpi_send(jhpb,nss,mpi_integer,& + king,idint,CG_COMM,ierr) + endif + + go to 10 + 100 print *, ' error in receiving message from emperor', me + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 200 print *, ' error in sending message to emperor' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 300 print *, ' error in communicating with emperor' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 956 format (' initial energy could not be calculated',41x) + 957 format (80x) + 965 format (' convergence code ',i2,' # of function calls ',& + i4,' # of gradient calls ',i4,10x) + 975 format (' energy ',1p,e12.4,' scaled gradient ',e11.3,32x) + end subroutine minim_jlee +!----------------------------------------------------------------------------- +! newconf.f +!----------------------------------------------------------------------------- + subroutine make_var(n,idum,iter_csa) + + use MD_data + use energy_data + use compare_data + use control_data, only: vdisulf + use geometry_data + use geometry, only: dist + include 'mpif.h' + +! use random, only: iran_num,ran_number +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.HAIRPIN' +! include 'COMMON.VAR' +! include 'COMMON.DISTFIT' +! include 'COMMON.GEO' +! include 'COMMON.CONTROL' + logical :: nicht_getan,nicht_getan1,fail,lfound + integer :: nharp,iharp(4,nres/3),nconf_harp + integer :: iisucc(mxio) + logical :: ifused(mxio) + integer :: nhx_seed(nseed),ihx_seed(4,nres/3,nseed) !max_seed + integer :: nhx_use(nseed),ihx_use(0:4,nres/3,nseed) + integer :: nlx_seed(nseed),ilx_seed(2,nres/3,nseed),& + nlx_use(nseed),ilx_use(nres/3,nseed) +! real(kind=4) :: ran1,ran2 + + integer :: i,j,k,n,idum,iter_csa,iran,index,n7frag,n8frag,n14frag,& + n15frag,nbefrag,nlx_tot,iters,i1,i2,i3,ntot_gen,ngen,iih,& + ij,jr,iim,nhx_tot,idummy,iter,iif,iig,icheck,ishift,iang,& + n8c,ih_start,ih_end,n7c,index2,isize,nsucc,nacc,j1,nran,& + ierror,ierrcode + real(kind=8) :: d + + write (iout,*) 'make_var : nseed=',nseed,'ntry=',n + index=0 + +!----------------------------------------- + if (n7.gt.0.or.n8.gt.0.or.n9.gt.0.or.n14.gt.0.or.n15.gt.0 & + .or.n16.gt.0.or.n17.gt.0.or.n18.gt.0) & + call select_frag(n7frag,n8frag,n14frag,& + n15frag,nbefrag,iter_csa) + +!--------------------------------------------------- +! N18 - random perturbation of one phi(=gamma) angle in a loop +! + IF (n18.gt.0) THEN + nlx_tot=0 + do iters=1,nseed + i1=is(iters) + nlx_seed(iters)=0 + do i2=1,n14frag + if (lvar_frag(i2,1).eq.i1) then + nlx_seed(iters)=nlx_seed(iters)+5 + ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) + ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) + ilx_use(nlx_seed(iters),iters)=5 + endif + enddo + nlx_use(iters)=nlx_seed(iters) + nlx_tot=nlx_tot+nlx_seed(iters) + enddo + + if (nlx_tot .ge. n18*nseed) then + ntot_gen=n18*nseed + else + ntot_gen=(nlx_tot/nseed)*nseed + endif + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nlx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nlx_seed(iters)) + if (ilx_use(iih,iters).gt.0) then + nicht_getan=.false. + ilx_use(iih,iters)=ilx_use(iih,iters)-1 + nlx_use(iters)=nlx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=18 + parent(1,index)=iseed + parent(2,index)=0 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + jr=iran_num(ilx_seed(1,iih,iters),ilx_seed(2,iih,iters)) + d=ran_number(-pi,pi) + dihang_in(2,jr-2,1,index)=pinorm(dihang_in(2,jr-2,1,index)+d) + + + if (ngen.eq.ntot_gen) goto 145 + endif + enddo + enddo + 145 continue + + ENDIF + + +!----------------------------------------- +! N17 : zip a beta in a seed by forcing one additional p-p contact +! + IF (n17.gt.0) THEN + nhx_tot=0 + do iters=1,nseed + i1=is(iters) + nhx_seed(iters)=0 + nhx_use(iters)=0 + do i2=1,nbefrag + if (avar_frag(i2,1).eq.i1) then + nhx_seed(iters)=nhx_seed(iters)+1 + ihx_use(2,nhx_seed(iters),iters)=1 + if (avar_frag(i2,5)-avar_frag(i2,3).le.3.and. & + avar_frag(i2,2).gt.1.and.avar_frag(i2,4).lt.nres) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 + ihx_use(0,nhx_seed(iters),iters)=1 + ihx_use(1,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + else + if (avar_frag(i2,4).gt.avar_frag(i2,5)) then + if (avar_frag(i2,2).gt.1.and. & + avar_frag(i2,4).lt.nres) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 + ihx_use(0,nhx_seed(iters),iters)=1 + ihx_use(1,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + if (avar_frag(i2,3).lt.nres.and. & + avar_frag(i2,5).gt.1) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)-1 + ihx_use(0,nhx_seed(iters),iters)= & + ihx_use(0,nhx_seed(iters),iters)+1 + ihx_use(2,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + else + if (avar_frag(i2,2).gt.1.and. & + avar_frag(i2,4).gt.1) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)-1 + ihx_use(0,nhx_seed(iters),iters)=1 + ihx_use(1,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + if (avar_frag(i2,3).lt.nres.and. & + avar_frag(i2,5).lt.nres) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)+1 + ihx_use(0,nhx_seed(iters),iters)= & + ihx_use(0,nhx_seed(iters),iters)+1 + ihx_use(2,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + endif + endif + endif + enddo + + nhx_tot=nhx_tot+nhx_use(iters) +!d write (iout,*) "debug N17",iters,nhx_seed(iters), +!d & nhx_use(iters),nhx_tot + enddo + + if (nhx_tot .ge. n17*nseed) then + ntot_gen=n17*nseed + else if (nhx_tot .ge. nseed) then + ntot_gen=(nhx_tot/nseed)*nseed + else + ntot_gen=nhx_tot + endif +!d write (iout,*) "debug N17==",ntot_gen,nhx_tot,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nhx_use(iters).gt.0) then +!d write (iout,*) "debug N17",nhx_use(iters),ngen,ntot_gen +!d write (iout,*) "debugN17^", +!d & (ihx_use(0,k,iters),k=1,nhx_use(iters)) + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nhx_seed(iters)) +!d write (iout,*) "debugN17^",iih + if (ihx_use(0,iih,iters).gt.0) then + iim=iran_num(1,2) +!d write (iout,*) "debugN17=",iih,nhx_seed(iters) +!d write (iout,*) "debugN17-",iim,'##', +!d & (ihx_use(k,iih,iters),k=0,2) +!d call flush(iout) + do while (ihx_use(iim,iih,iters).eq.1) + iim=iran_num(1,2) +!d write (iout,*) "debugN17-",iim,'##', +!d & (ihx_use(k,iih,iters),k=0,2) +!d call flush(iout) + enddo + nicht_getan=.false. + ihx_use(iim,iih,iters)=1 + ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 + nhx_use(iters)=nhx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=17 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + if (iim.eq.1) then + idata(1,index)=ihx_seed(1,iih,iters) + idata(2,index)=ihx_seed(2,iih,iters) + else + idata(1,index)=ihx_seed(3,iih,iters) + idata(2,index)=ihx_seed(4,iih,iters) + endif + + if (ngen.eq.ntot_gen) goto 115 + endif + enddo + enddo + 115 continue + write (iout,*) "N17",n17," ngen/nseed",ngen/nseed,& + ngen,nseed + + + ENDIF +!----------------------------------------- +! N16 : slide non local beta in a seed by +/- 1 or +/- 2 +! + IF (n16.gt.0) THEN + nhx_tot=0 + do iters=1,nseed + i1=is(iters) + nhx_seed(iters)=0 + do i2=1,n7frag + if (bvar_frag(i2,1).eq.i1) then + nhx_seed(iters)=nhx_seed(iters)+1 + ihx_seed(1,nhx_seed(iters),iters)=bvar_frag(i2,3) + ihx_seed(2,nhx_seed(iters),iters)=bvar_frag(i2,4) + ihx_seed(3,nhx_seed(iters),iters)=bvar_frag(i2,5) + ihx_seed(4,nhx_seed(iters),iters)=bvar_frag(i2,6) + ihx_use(0,nhx_seed(iters),iters)=4 + do i3=1,4 + ihx_use(i3,nhx_seed(iters),iters)=0 + enddo + endif + enddo + nhx_use(iters)=4*nhx_seed(iters) + nhx_tot=nhx_tot+nhx_seed(iters) +!d write (iout,*) "debug N16",iters,nhx_seed(iters) + enddo + + if (4*nhx_tot .ge. n16*nseed) then + ntot_gen=n16*nseed + else if (4*nhx_tot .ge. nseed) then + ntot_gen=(4*nhx_tot/nseed)*nseed + else + ntot_gen=4*nhx_tot + endif + write (iout,*) "debug N16",ntot_gen,4*nhx_tot,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nhx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nhx_seed(iters)) + if (ihx_use(0,iih,iters).gt.0) then + iim=iran_num(1,4) + do while (ihx_use(iim,iih,iters).eq.1) +!d write (iout,*) iim, +!d & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) + iim=iran_num(1,4) + enddo + nicht_getan=.false. + ihx_use(iim,iih,iters)=1 + ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 + nhx_use(iters)=nhx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=16 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do i=1,4 + idata(i,index)=ihx_seed(i,iih,iters) + enddo + idata(5,index)=iim + + if (ngen.eq.ntot_gen) goto 116 + endif + enddo + enddo + 116 continue + write (iout,*) "N16",n16," ngen/nseed",ngen/nseed,& + ngen,nseed + ENDIF +!----------------------------------------- +! N15 : copy two 2nd structure elements from 1 or 2 conf. in bank to a seed +! + IF (n15.gt.0) THEN + + do iters=1,nseed + iseed=is(iters) + do i=1,mxio + ifused(i)=.false. + enddo + + do idummy=1,n15 + iter=0 + 84 continue + + iran=0 + iif=iran_num(1,n15frag) + do while( (ifused(iif) .or. svar_frag(iif,1).eq.iseed) .and. & + iran.le.mxio ) + iif=iran_num(1,n15frag) + iran=iran+1 + enddo + if(iran.ge.mxio) goto 811 + + iran=0 + iig=iran_num(1,n15frag) + do while( (ifused(iig) .or. svar_frag(iig,1).eq.iseed .or. & + .not.(svar_frag(iif,3).lt.svar_frag(iig,2).or. & + svar_frag(iig,3).lt.svar_frag(iif,2)) ) .and. & + iran.le.mxio ) + iig=iran_num(1,n15frag) + iran=iran+1 + enddo + if(iran.ge.mxio) goto 811 + + index=index+1 + movenx(index)=15 + parent(1,index)=iseed + parent(2,index)=svar_frag(iif,1) + parent(3,index)=svar_frag(iig,1) + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + ifused(iif)=.true. + ifused(iig)=.true. + call newconf_copy(idum,dihang_in(1,1,1,index),& + svar_frag(iif,1),svar_frag(iif,2),svar_frag(iif,3)) + + do j=svar_frag(iig,2),svar_frag(iig,3) + do i=1,4 + dihang_in(i,j,1,index)=bvar(i,j,1,svar_frag(iig,1)) + enddo + enddo + + + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) then + index=index-1 + ifused(iif)=.false. + goto 84 + endif + endif + + 811 continue + enddo + enddo + ENDIF + +!----------------------------------------- +! N14 local_move (Maurizio) for loops in a seed +! + IF (n14.gt.0) THEN + nlx_tot=0 + do iters=1,nseed + i1=is(iters) + nlx_seed(iters)=0 + do i2=1,n14frag + if (lvar_frag(i2,1).eq.i1) then + nlx_seed(iters)=nlx_seed(iters)+3 + ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) + ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) + ilx_use(nlx_seed(iters),iters)=3 + endif + enddo + nlx_use(iters)=nlx_seed(iters) + nlx_tot=nlx_tot+nlx_seed(iters) +!d write (iout,*) "debug N14",iters,nlx_seed(iters) + enddo + + if (nlx_tot .ge. n14*nseed) then + ntot_gen=n14*nseed + else + ntot_gen=(nlx_tot/nseed)*nseed + endif +!d write (iout,*) "debug N14",ntot_gen,n14frag,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nlx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nlx_seed(iters)) + if (ilx_use(iih,iters).gt.0) then + nicht_getan=.false. + ilx_use(iih,iters)=ilx_use(iih,iters)-1 + nlx_use(iters)=nlx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=14 + parent(1,index)=iseed + parent(2,index)=0 + + idata(1,index)=ilx_seed(1,iih,iters) + idata(2,index)=ilx_seed(2,iih,iters) + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + if (ngen.eq.ntot_gen) goto 131 + endif + enddo + enddo + 131 continue +!d write (iout,*) "N14",n14," ngen/nseed",ngen/nseed, +!d & ngen,nseed + + ENDIF +!----------------------------------------- +! N9 : shift a helix in a seed +! + IF (n9.gt.0) THEN + nhx_tot=0 + do iters=1,nseed + i1=is(iters) + nhx_seed(iters)=0 + do i2=1,n8frag + if (hvar_frag(i2,1).eq.i1) then + nhx_seed(iters)=nhx_seed(iters)+1 + ihx_seed(1,nhx_seed(iters),iters)=hvar_frag(i2,2) + ihx_seed(2,nhx_seed(iters),iters)=hvar_frag(i2,3) + ihx_use(0,nhx_seed(iters),iters)=4 + do i3=1,4 + ihx_use(i3,nhx_seed(iters),iters)=0 + enddo + endif + enddo + nhx_use(iters)=4*nhx_seed(iters) + nhx_tot=nhx_tot+nhx_seed(iters) +!d write (iout,*) "debug N9",iters,nhx_seed(iters) + enddo + + if (4*nhx_tot .ge. n9*nseed) then + ntot_gen=n9*nseed + else + ntot_gen=(4*nhx_tot/nseed)*nseed + endif +!d write (iout,*) "debug N9",ntot_gen,n8frag,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nhx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nhx_seed(iters)) + if (ihx_use(0,iih,iters).gt.0) then + iim=iran_num(1,4) + do while (ihx_use(iim,iih,iters).eq.1) +!d write (iout,*) iim, +!d & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) + iim=iran_num(1,4) + enddo + nicht_getan=.false. + ihx_use(iim,iih,iters)=1 + ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 + nhx_use(iters)=nhx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=9 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + jstart=max(nnt,ihx_seed(1,iih,iters)+1) + jend=min(nct,ihx_seed(2,iih,iters)) +!d write (iout,*) "debug N9",iters,iih,jstart,jend + if (iim.eq.1) then + ishift=-2 + else if (iim.eq.2) then + ishift=-1 + else if (iim.eq.3) then + ishift=1 + else if (iim.eq.4) then + ishift=2 + else + write (iout,*) 'CHUJ NASTAPIL: iim=',iim +#ifdef MPI !el + call mpi_abort(mpi_comm_world,ierror,ierrcode) +#endif + endif + do j=jstart,jend + if (itype(j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (j+ishift.ge.nnt.and.j+ishift.le.nct) & + dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) + enddo + enddo + if (ishift.gt.0) then + do j=0,ishift-1 + if (itype(jend+j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (jend+j.ge.nnt.and.jend+j.le.nct) & + dihang_in(i,jstart+j,1,index)=bvar(i,jend+j,1,iseed) + enddo + enddo + else + do j=0,-ishift-1 + if (itype(jstart+j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (jend+j.ge.nnt.and.jend+j.le.nct) & + dihang_in(i,jend+j,1,index)=bvar(i,jstart+j,1,iseed) + enddo + enddo + endif + if (ngen.eq.ntot_gen) goto 133 + endif + enddo + enddo + 133 continue +!d write (iout,*) "N9",n9," ngen/nseed",ngen/nseed, +!d & ngen,nseed + + ENDIF +!----------------------------------------- +! N8 : copy a helix from bank to seed +! + if (n8.gt.0) then + if (n8frag.lt.n8) then + write (iout,*) "N8: only ",n8frag,'helices' + n8c=n8frag + else + n8c=n8 + endif + + do iters=1,nseed + iseed=is(iters) + do i=1,mxio + ifused(i)=.false. + enddo + + + do idummy=1,n8c + iter=0 + 94 continue + iran=0 + iif=iran_num(1,n8frag) + do while( (ifused(iif) .or. hvar_frag(iif,1).eq.iseed) .and. & + iran.le.mxio ) + iif=iran_num(1,n8frag) + iran=iran+1 + enddo + + if(iran.ge.mxio) goto 911 + + index=index+1 + movenx(index)=8 + parent(1,index)=iseed + parent(2,index)=hvar_frag(iif,1) + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + ifused(iif)=.true. + if (hvar_frag(iif,3)-hvar_frag(iif,2).le.6) then + call newconf_copy(idum,dihang_in(1,1,1,index),& + hvar_frag(iif,1),hvar_frag(iif,2),hvar_frag(iif,3)) + else + ih_start=iran_num(hvar_frag(iif,2),hvar_frag(iif,3)-6) + ih_end=iran_num(ih_start,hvar_frag(iif,3)) + call newconf_copy(idum,dihang_in(1,1,1,index),& + hvar_frag(iif,1),ih_start,ih_end) + endif + iter=iter+1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) then + index=index-1 + ifused(iif)=.false. + goto 94 + endif + endif + + + 911 continue + + enddo + enddo + + endif + +!----------------------------------------- +! N7 : copy nonlocal beta fragment from bank to seed +! + if (n7.gt.0) then + if (n7frag.lt.n7) then + write (iout,*) "N7: only ",n7frag,'nonlocal fragments' + n7c=n7frag + else + n7c=n7 + endif + + do i=1,nres + do j=1,mxio2 + iff_in(i,j)=0 + enddo + enddo + index2=0 + do i=1,mxio + isend2(i)=0 + enddo + + do iters=1,nseed + iseed=is(iters) + do i=1,mxio + ifused(i)=.false. + enddo + + do idummy=1,n7c + iran=0 + iif=iran_num(1,n7frag) + do while( (ifused(iif) .or. bvar_frag(iif,1).eq.iseed) .and. & + iran.le.mxio ) + iif=iran_num(1,n7frag) + iran=iran+1 + enddo + +!d write (*,'(3i5,l,4i5)'),iters,idummy,iif,ifused(iif), +!d & bvar_frag(iif,1),iseed,iran,index2 + + if(iran.ge.mxio) goto 999 + if(index2.ge.mxio2) goto 999 + + index=index+1 + movenx(index)=7 + parent(1,index)=iseed + parent(2,index)=bvar_frag(iif,1) + index2=index2+1 + isend2(index)=index2 + ifused(iif)=.true. + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in2(i,j,k,index2)=bvar(i,j,k,bvar_frag(iif,1)) + enddo + enddo + enddo + + if (bvar_frag(iif,2).eq.4) then + do i=bvar_frag(iif,3),bvar_frag(iif,4) + iff_in(i,index2)=1 + enddo + if (bvar_frag(iif,5).lt.bvar_frag(iif,6)) then +!d print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), +!d & bvar_frag(iif,5),bvar_frag(iif,6) + do i=bvar_frag(iif,5),bvar_frag(iif,6) + iff_in(i,index2)=1 + enddo + else +!d print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), +!d & bvar_frag(iif,6),bvar_frag(iif,5) + do i=bvar_frag(iif,6),bvar_frag(iif,5) + iff_in(i,index2)=1 + enddo + endif + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + + 999 continue + + enddo + enddo + + endif +!----------------------------------------------- +! N6 : copy random continues fragment from bank to seed +! + do iters=1,nseed + iseed=is(iters) + do idummy=1,n6 + isize=(is2-is1+1)*ran1(idum)+is1 + index=index+1 + movenx(index)=6 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 104 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 104 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + parent(1,index)=iseed + parent(2,index)=i1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 104 + endif + enddo + enddo +!----------------------------------------- + if (n3.gt.0.or.n4.gt.0) call gen_hairpin + nconf_harp=0 + do iters=1,nseed + if (nharp_seed(iters).gt.0) nconf_harp=nconf_harp+1 + enddo +!----------------------------------------- +! N3 : copy hairpin from bank to seed +! + do iters=1,nseed + iseed=is(iters) + nsucc=0 + nacc=0 + do idummy=1,n3 + index=index+1 + iter=0 + 124 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 124 + do k=1,nsucc + if (i1.eq.iisucc(k).and.nsucc.lt.nconf_harp-1) goto 124 + enddo + nsucc=nsucc+1 + iisucc(nsucc)=i1 + iter=iter+1 + call newconf_residue_hairpin(idum,dihang_in(1,1,1,index),& + i1,fail) + if (fail) then + if (icycle.le.0 .and. nsucc.eq.nconf .or. & + icycle.gt.0 .and. nsucc.eq.nbank) then + index=index-1 + goto 125 + else + goto 124 + endif + endif + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 124 + endif + movenx(index)=3 + parent(1,index)=iseed + parent(2,index)=i1 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + nacc=nacc+1 + enddo +! if not enough hairpins, supplement with windows + 125 continue +!dd if (n3.ne.0) write (iout,*) "N3",n3," nsucc",nsucc," nacc",nacc + do idummy=nacc+1,n3 + isize=(is2-is1+1)*ran1(idum)+is1 + index=index+1 + movenx(index)=6 + parent(1,index)=iseed + parent(2,index)=i1 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 114 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 114 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 114 + endif + enddo + enddo +!----------------------------------------- +! N4 : shift a turn in hairpin in seed +! + IF (N4.GT.0) THEN + if (4*nharp_tot .ge. n4*nseed) then + ntot_gen=n4*nseed + else + ntot_gen=(4*nharp_tot/nseed)*nseed + endif + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) +! write (iout,*) 'iters',iters,' iseed',iseed,' nharp_seed', +! & nharp_seed(iters),' nharp_use',nharp_use(iters), +! & ' ntot_gen',ntot_gen +! write (iout,*) 'iharp_use(0)', +! & (iharp_use(0,k,iters),k=1,nharp_seed(iters)) + if (nharp_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nharp_seed(iters)) +! write (iout,*) 'iih',iih,' iharp_use', +! & (iharp_use(k,iih,iters),k=1,4) + if (iharp_use(0,iih,iters).gt.0) then + nicht_getan1=.true. + do while (nicht_getan1) + iim=iran_num(1,4) + nicht_getan1=iharp_use(iim,iih,iters).eq.1 + enddo + nicht_getan=.false. + iharp_use(iim,iih,iters)=1 + iharp_use(0,iih,iters)=iharp_use(0,iih,iters)-1 + nharp_use(iters)=nharp_use(iters)-1 +!dd write (iout,'(a16,i3,a5,i2,a10,2i4)') +!dd & 'N4 selected hairpin',iih,' move',iim,' iharp_seed', +!dd & iharp_seed(1,iih,iters),iharp_seed(2,iih,iters) + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=4 + parent(1,index)=iseed + parent(2,index)=0 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + jstart=iharp_seed(1,iih,iters)+1 + jend=iharp_seed(2,iih,iters) + if (iim.eq.1) then + ishift=-2 + else if (iim.eq.2) then + ishift=-1 + else if (iim.eq.3) then + ishift=1 + else if (iim.eq.4) then + ishift=2 + else + write (iout,*) 'CHUJ NASTAPIL: iim=',iim +#ifdef MPI !el + call mpi_abort(mpi_comm_world,ierror,ierrcode) +#endif !el + endif +! write (iout,*) 'jstart',jstart,' jend',jend,' ishift',ishift +! write (iout,*) 'Before turn shift' +! do j=2,nres-1 +! theta(j+1)=dihang_in(1,j,1,index) +! phi(j+2)=dihang_in(2,j,1,index) +! alph(j)=dihang_in(3,j,1,index) +! omeg(j)=dihang_in(4,j,1,index) +! enddo +! call intout + do j=jstart,jend + if (itype(j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (j+ishift.ge.nnt.and.j+ishift.le.nct) & + dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) + enddo + enddo +! write (iout,*) 'After turn shift' +! do j=2,nres-1 +! theta(j+1)=dihang_in(1,j,1,index) +! phi(j+2)=dihang_in(2,j,1,index) +! alph(j)=dihang_in(3,j,1,index) +! omeg(j)=dihang_in(4,j,1,index) +! enddo +! call intout + if (ngen.eq.ntot_gen) goto 135 + endif + enddo + enddo +! if not enough hairpins, supplement with windows +! write (iout,*) 'end of enddo' + 135 continue +!dd write (iout,*) "N4",n4," ngen/nseed",ngen/nseed, +!dd & ngen,nseed + do iters=1,nseed + iseed=is(iters) + do idummy=ngen/nseed+1,n4 + isize=(is2-is1+1)*ran1(idum)+is1 + index=index+1 + movenx(index)=6 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + iter=0 + 134 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 134 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + parent(1,index)=iseed + parent(2,index)=i1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 134 + endif + enddo + enddo + ENDIF +!----------------------------------------- +! N5 : copy one residue from bank to seed (normally switched off - use N1) +! + do iters=1,nseed + iseed=is(iters) + isize=1 + do i=1,n5 + index=index+1 + movenx(index)=5 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + iter=0 + 105 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 105 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + parent(1,index)=iseed + parent(2,index)=i1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 105 + endif + enddo + enddo +!----------------------------------------- +! N2 : copy backbone of one residue from bank or first bank to seed +! (normally switched off - use N1) +! + do iters=1,nseed + iseed=is(iters) + do i=n2,1,-1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + iseed=ran1(idum)*nconf+1 + iseed=nbank-nconf+iseed + endif + index=index+1 + movenx(index)=2 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 102 i1= ran1(idum)*nbank+1 + if(i1.eq.iseed) goto 102 + iter=iter+1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + nran=mod(i-1,nran0)+3 + call newconf1arr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=-iseed + parent(2,index)=-i1 + else if(icycle.le.0.and.iters.le.iuse) then + nran=mod(i-1,nran0)+1 + call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + nran=mod(i-1,nran1)+1 + if(ran1(idum).lt.0.5) then + call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + call newconf1abb(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=i1 + endif + endif + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 102 + endif + enddo + enddo +!----------------------------------------- +! N1 : copy backbone or sidechain of one residue from bank or +! first bank to seed +! + do iters=1,nseed + iseed=is(iters) + do i=n1,1,-1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + iseed=ran1(idum)*nconf+1 + iseed=nbank-nconf+iseed + endif + index=index+1 + movenx(index)=1 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 101 i1= ran1(idum)*nbank+1 + + if(i1.eq.iseed) goto 101 + iter=iter+1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + nran=mod(i-1,nran0)+3 + call newconf1rr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=-iseed + parent(2,index)=-i1 + else if(icycle.le.0.and.iters.le.iuse) then + nran=mod(i-1,nran0)+1 + call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + nran=mod(i-1,nran1)+1 + if(ran1(idum).lt.0.5) then + call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + call newconf1bb(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=i1 + endif + endif + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 101 + endif + enddo + enddo +!----------------------------------------- +! N0 just all seeds +! + IF (n0.gt.0) THEN + do iters=1,nseed + iseed=is(iters) + index=index+1 + movenx(index)=0 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + enddo + ENDIF +!----------------------------------------- + if (vdisulf) then + do iters=1,nseed + iseed=is(iters) + + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,iseed) + phi(j+2)=bvar(2,j,k,iseed) + alph(j)=bvar(3,j,k,iseed) + omeg(j)=bvar(4,j,k,iseed) + enddo + enddo + call chainbuild + +!d write(iout,*) 'makevar DYNSS',iseed,'#',bvar_ns(iseed), +!d & (bvar_s(k,iseed),k=1,bvar_ns(iseed)), +!d & bvar_nss(iseed), +!d & (bvar_ss(1,k,iseed)-nres,'-', +!d & bvar_ss(2,k,iseed)-nres,k=1,bvar_nss(iseed)) + + do i1=1,bvar_ns(iseed) +! +! N10 fussion of free halfcysteines in seed +! first select CYS with distance < 7A +! + do j1=i1+1,bvar_ns(iseed) + if (dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres) & + .lt.7.0.and. & + iabs(bvar_s(i1,iseed)-bvar_s(j1,iseed)).gt.3) then + + index=index+1 + movenx(index)=10 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + ij=bvar_nss(iseed)+1 + nss_in(index)=ij + iss_in(ij,index)=bvar_s(i1,iseed)+nres + jss_in(ij,index)=bvar_s(j1,iseed)+nres + +!d write(iout,*) 'makevar NSS0',index, +!d & dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres), +!d & nss_in(index),iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + enddo +! +! N11 type I transdisulfidation +! + do j1=1,bvar_nss(iseed) + if (dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)) & + .lt.7.0.and. & + iabs(bvar_s(i1,iseed)-(bvar_ss(1,j1,iseed)-nres)) & + .gt.3) then + + index=index+1 + movenx(index)=11 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(j1,index)=bvar_s(i1,iseed)+nres + jss_in(j1,index)=bvar_ss(1,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(1,j1,iseed) + jss_in(j1,index)=bvar_s(i1,iseed)+nres + endif + +!d write(iout,*) 'makevar NSS1 #1',index, +!d & bvar_s(i1,iseed),bvar_ss(1,j1,iseed)-nres, +!d & dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)), +!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +!d & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + endif + if (dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)) & + .lt.7.0.and. & + iabs(bvar_s(i1,iseed)-(bvar_ss(2,j1,iseed)-nres)) & + .gt.3) then + + index=index+1 + movenx(index)=11 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(j1,index)=bvar_s(i1,iseed)+nres + jss_in(j1,index)=bvar_ss(2,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(2,j1,iseed) + jss_in(j1,index)=bvar_s(i1,iseed)+nres + endif + + +!d write(iout,*) 'makevar NSS1 #2',index, +!d & bvar_s(i1,iseed),bvar_ss(2,j1,iseed)-nres, +!d & dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)), +!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +!d & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + enddo + enddo + +! +! N12 type II transdisulfidation +! + do i1=1,bvar_nss(iseed) + do j1=i1+1,bvar_nss(iseed) + if (dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)) & + .lt.7.0.and. & + dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)) & + .lt.7.0.and. & + iabs(bvar_ss(1,i1,iseed)-bvar_ss(1,j1,iseed)) & + .gt.3.and. & + iabs(bvar_ss(2,i1,iseed)-bvar_ss(2,j1,iseed)) & + .gt.3) then + index=index+1 + movenx(index)=12 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.i1 .and. ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(i1,index)=bvar_ss(1,i1,iseed) + jss_in(i1,index)=bvar_ss(1,j1,iseed) + if (iss_in(i1,index).gt.jss_in(i1,index)) then + iss_in(i1,index)=bvar_ss(1,j1,iseed) + jss_in(i1,index)=bvar_ss(1,i1,iseed) + endif + iss_in(j1,index)=bvar_ss(2,i1,iseed) + jss_in(j1,index)=bvar_ss(2,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(2,j1,iseed) + jss_in(j1,index)=bvar_ss(2,i1,iseed) + endif + + +!d write(iout,*) 'makevar NSS2 #1',index, +!d & bvar_ss(1,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, +!d & dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)), +!d & bvar_ss(2,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, +!d & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)), +!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +!d & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + + if (dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)) & + .lt.7.0.and. & + dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)) & + .lt.7.0.and. & + iabs(bvar_ss(1,i1,iseed)-bvar_ss(2,j1,iseed)) & + .gt.3.and. & + iabs(bvar_ss(2,i1,iseed)-bvar_ss(1,j1,iseed)) & + .gt.3) then + index=index+1 + movenx(index)=12 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.i1 .and. ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(i1,index)=bvar_ss(1,i1,iseed) + jss_in(i1,index)=bvar_ss(2,j1,iseed) + if (iss_in(i1,index).gt.jss_in(i1,index)) then + iss_in(i1,index)=bvar_ss(2,j1,iseed) + jss_in(i1,index)=bvar_ss(1,i1,iseed) + endif + iss_in(j1,index)=bvar_ss(2,i1,iseed) + jss_in(j1,index)=bvar_ss(1,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(1,j1,iseed) + jss_in(j1,index)=bvar_ss(2,i1,iseed) + endif + + +!d write(iout,*) 'makevar NSS2 #2',index, +!d & bvar_ss(1,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, +!d & dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)), +!d & bvar_ss(2,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, +!d & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)), +!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +!d & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + + + enddo + enddo +! +! N13 removal of disulfide bond +! + if (bvar_nss(iseed).gt.0) then + i1=bvar_nss(iseed)*ran1(idum)+1 + + index=index+1 + movenx(index)=13 + parent(1,index)=iseed + parent(2,index)=0 + ij=0 + do j1=1,bvar_nss(iseed) + if (j1.ne.i1) then + ij=ij+1 + iss_in(ij,index)=bvar_ss(1,j1,iseed) + jss_in(ij,index)=bvar_ss(2,j1,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed)-1 + +!d write(iout,*) 'NSS3',index,i1, +!d & bvar_ss(1,i1,iseed)-nres,'=',bvar_ss(2,i1,iseed)-nres,'#', +!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +!d & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + + enddo + endif +!----------------------------------------- + + + + if(index.ne.n) write(iout,*)'make_var : ntry=',index + + n=index +!d do ii=1,n +!d write (istat,*) "======== ii=",ii," the dihang array" +!d do i=1,nres +!d write (istat,'(i5,4f15.5)') i,(dihang_in(k,i,1,ii)*rad2deg,k=1,4) +!d enddo +!d enddo + return + end subroutine make_var +!----------------------------------------------------------------------------- + subroutine check_old(icheck,n) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + integer :: icheck,n,i1,i2,m,j,i + real(kind=8) :: ctdif,ctdiff,diff,dif + + data ctdif /10./ + data ctdiff /60./ + + i1=n + do i2=1,n-1 + diff=0.d0 + do m=1,numch + do j=2,nres-1 + do i=1,4 + dif=rad2deg*dabs(dihang_in(i,j,m,i1)-dihang_in(i,j,m,i2)) + if(dif.gt.180.0) dif=360.0-dif + if(dif.gt.ctdif) goto 100 + diff=diff+dif + if(diff.gt.ctdiff) goto 100 + enddo + enddo + enddo + icheck=1 + return + 100 continue + enddo + + icheck=0 + + return + end subroutine check_old +!----------------------------------------------------------------------------- + subroutine newconf1rr(idum,vvar,nran,i1) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind + real(kind=8) :: ctdif,dif + + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=rvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=ntotgr + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end subroutine newconf1rr +!----------------------------------------------------------------------------- + subroutine newconf1br(idum,vvar,nran,i1) + + use energy_data, only: ndih_nconstr,idih_nconstr + use control_data, only: i2ndstr +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,nran,i1,iran,index,number,iter,juhc,ind + real(kind=8) :: ctdif,dif,rtmp + + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=ntotgr + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + i=0 + do j=1,ndih_nconstr + if(igroup(2,1,iran).eq.idih_nconstr(j))i=j + enddo + if(i.eq.0) then + juhc=0 +4321 juhc=juhc+1 + iran= ran1(idum)*number+1 + i=0 + do j=1,ndih_nconstr + if(igroup(2,1,iran).eq.idih_nconstr(j))i=j + enddo + if(i.eq.0.or.juhc.lt.1000)goto 4321 + if(juhc.eq.1000) then + print *, 'move 6 : failed to find unconstrained group' + write(iout,*) 'move 6 : failed to find unconstrained group' + endif + endif + endif + endif + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end subroutine newconf1br +!----------------------------------------------------------------------------- + subroutine newconf1bb(idum,vvar,nran,i1) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind + real(kind=8) :: ctdif,dif + + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=ntotgr + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end subroutine newconf1bb +!----------------------------------------------------------------------------- + subroutine newconf1arr(idum,vvar,nran,i1) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind + real(kind=8) :: ctdif,dif + + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=rvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=nres-2 + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end subroutine newconf1arr +!----------------------------------------------------------------------------- + subroutine newconf1abr(idum,vvar,nran,i1) + + use energy_data, only: ndih_nconstr,idih_nconstr + use control_data, only: i2ndstr +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind + real(kind=8) :: ctdif,dif,rtmp + + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=nres-2 + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + iran=ran1(idum)*ndih_nconstr+1 + iran=idih_nconstr(iran) + endif + endif + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end subroutine newconf1abr +!----------------------------------------------------------------------------- + subroutine newconf1abb(idum,vvar,nran,i1) + + use energy_data, only: ndih_nconstr,idih_nconstr + use control_data, only: i2ndstr +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind + real(kind=8) :: ctdif,dif,rtmp + + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=nres-2 + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + iran=ran1(idum)*ndih_nconstr+1 + iran=idih_nconstr(iran) + endif + endif + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end subroutine newconf1abb +!----------------------------------------------------------------------------- + subroutine newconf_residue(idum,vvar,i1,isize) + + use energy_data, only: ndih_nconstr,idih_nconstr + use control_data, only: i2ndstr + use MPI_data + include 'mpif.h' +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,i1,isize,iran,number,iter,ind,iend,istart,& + ierror,ierrcode + real(kind=8) :: ctdif,dif,rtmp + + ctdif=10. + + if (iseed.gt.mxio .or. iseed.lt.1) then + write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + + k=1 + number=nres+isize-2 + iter=1 + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + iran=ran1(idum)*ndih_nconstr+1 + iran=idih_nconstr(iran) + endif + endif + istart=iran-isize+1 + iend=iran + if(istart.lt.2) istart=2 + if(iend.gt.nres-1) iend=nres-1 + + if(iter.eq.1) goto 11 + do ind=1,iter-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do j=istart,iend + do i=1,4 + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + enddo + iold(iter)=iran + iter=iter+1 + if(iter.gt.number) goto 20 + goto 10 + + 20 continue + do j=istart,iend + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + enddo + + return + end subroutine newconf_residue +!----------------------------------------------------------------------------- + subroutine newconf_copy(idum,vvar,i1,istart,iend) + + use MPI_data + include 'mpif.h' +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: i,j,k,idum,i1,istart,iend,ierror,ierrcode + real(kind=8) :: ctdif,dif + + ctdif=10. + + if (iseed.gt.mxio .or. iseed.lt.1) then + write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + + do j=istart,iend + do i=1,4 + vvar(i,j,1)=bvar(i,j,1,i1) + enddo + enddo + + return + end subroutine newconf_copy +!----------------------------------------------------------------------------- + subroutine newconf_residue_hairpin(idum,vvar,i1,fail) + + use geometry_data +! use random, only: iran_num + use MPI_data + use compare, only:hairpin + + include 'mpif.h' +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! real(kind=4) :: ran1,ran2 + real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) + integer,dimension(ntotal) :: iold + integer :: nharp,iharp(4,nres/3),icipa(nres/3) + logical :: fail,not_done + integer :: idum,i,j,k,i1,iend,istart,iii,n_used,icount,iih,& + ierror,ierrcode + real(kind=8) :: ctdif,dif + + ctdif=10. + + fail=.false. + if (iseed.gt.mxio .or. iseed.lt.1) then + write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,i1) + phi(j+2)=bvar(2,j,k,i1) + alph(j)=bvar(3,j,k,i1) + omeg(j)=bvar(4,j,k,i1) + enddo + enddo +! call intout + call chainbuild + call hairpin(.false.,nharp,iharp) + + if (nharp.eq.0) then + fail=.true. + return + endif + + n_used=0 + + DO III=1,NHARP + + not_done = .true. + icount=0 + do while (not_done) + icount=icount+1 + iih=iran_num(1,nharp) + do k=1,n_used + if (iih.eq.icipa(k)) then + iih=0 + goto 22 + endif + enddo + not_done=.false. + n_used=n_used+1 + icipa(n_used)=iih + 22 continue + not_done = not_done .and. icount.le.nharp + enddo + + if (iih.eq.0) then + write (iout,*) "CHUJ NASTAPIL W NEWCONF_RESIDUE_HAIRPIN!!!!" + fail=.true. + return + endif + + istart=iharp(1,iih)+1 + iend=iharp(2,iih) + +!dd write (iout,*) "newconf_residue_hairpin: iih",iih, +!dd & " istart",istart," iend",iend + + do k=1,numch + do j=istart,iend + do i=1,4 + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + enddo + enddo + goto 10 + 20 continue + do k=1,numch + do j=istart,iend + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + enddo + enddo +! do j=1,numch +! do l=2,nres-1 +! write (iout,'(4f8.3)') (rad2deg*vvar(i,l,j),i=1,4) +! enddo +! enddo + return + 10 continue + ENDDO + + fail=.true. + + return + end subroutine newconf_residue_hairpin +!----------------------------------------------------------------------------- + subroutine gen_hairpin + + use geometry_data + use MD_data + use compare, only:hairpin +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.HAIRPIN' + integer :: i1,j,k,iters + +! write (iout,*) 'Entering GEN_HAIRPIN' + do iters=1,nseed + i1=is(iters) + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,i1) + phi(j+2)=bvar(2,j,k,i1) + alph(j)=bvar(3,j,k,i1) + omeg(j)=bvar(4,j,k,i1) + enddo + enddo + call chainbuild + call hairpin(.false.,nharp_seed(iters),iharp_seed(1,1,iters)) + enddo + + nharp_tot=0 + do iters=1,nseed + nharp_tot=nharp_tot+nharp_seed(iters) + nharp_use(iters)=4*nharp_seed(iters) + do j=1,nharp_seed(iters) + iharp_use(0,j,iters)=4 + do k=1,4 + iharp_use(k,j,iters)=0 + enddo + enddo + enddo + + write (iout,*) 'GEN_HAIRPIN: nharp_tot',nharp_tot +!dd do i=1,nseed +!dd write (iout,*) 'seed',i +!dd write (iout,*) 'nharp_seed',nharp_seed(i), +!dd & ' nharp_use',nharp_use(i) +!d write (iout,*) 'iharp_seed, iharp_use' +!d do j=1,nharp_seed(i) +!d write (iout,'(7i3)') iharp_seed(1,j,i),iharp_seed(2,j,i), +!d & (iharp_use(k,j,i),k=0,4) +!d enddo +!dd enddo + return + end subroutine gen_hairpin +!----------------------------------------------------------------------------- + subroutine select_frag(nn,nh,nl,ns,nb,i_csa) + + use geometry_data + use MD_data + use compare_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.HAIRPIN' +! include 'COMMON.DISTFIT' + character(len=50) :: linia + integer :: isec(nres) + integer :: i,j,i1,k,nn,nh,nl,ns,nb,i_csa,nl1,ns1 + + nn=0 + nh=0 + nl=0 + ns=0 + nb=0 +!d write (iout,*) 'Entering select_frag' + do i1=1,nbank + do i=1,nres + isec(i)=0 + enddo + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,i1) + phi(j+2)=bvar(2,j,k,i1) + alph(j)=bvar(3,j,k,i1) + omeg(j)=bvar(4,j,k,i1) + enddo + enddo + call chainbuild +!d write (iout,*) ' -- ',i1,' -- ' + call secondary2(.false.) +! +! bvar_frag nn==pair of nonlocal strands in beta sheet (loop>4) +! strands > 4 residues; used by N7 and N16 +! + do j=1,nbfrag +! +!test 09/12/02 bfrag(2,j)-bfrag(1,j).gt.3 +! + do i=bfrag(1,j),bfrag(2,j) + isec(i)=1 + enddo + do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) + isec(i)=1 + enddo + + if ( (bfrag(3,j).lt.bfrag(4,j) .or. & + bfrag(4,j)-bfrag(2,j).gt.4) .and. & + bfrag(2,j)-bfrag(1,j).gt.4 ) then + nn=nn+1 + + + if (bfrag(3,j).lt.bfrag(4,j)) then + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') & + "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& + ",",bfrag(3,j)-1,"-",bfrag(4,j)-1 + else + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') & + "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& + ",",bfrag(4,j)-1,"-",bfrag(3,j)-1 + + endif +!d call write_pdb(i_csa*1000+nn+nh,linia,0d0) + + bvar_frag(nn,1)=i1 + bvar_frag(nn,2)=4 + do i=1,4 + bvar_frag(nn,i+2)=bfrag(i,j) + enddo + endif + enddo + +! +! hvar_frag nh==helices; used by N8 and N9 +! + do j=1,nhfrag + + do i=hfrag(1,j),hfrag(2,j) + isec(i)=2 + enddo + + if ( hfrag(2,j)-hfrag(1,j).gt.4 ) then + nh=nh+1 + +!d write(linia,'(a6,i3,a1,i3)') +!d & "select",hfrag(1,j)-1,"-",hfrag(2,j)-1 +!d call write_pdb(i_csa*1000+nn+nh,linia,0d0) + + hvar_frag(nh,1)=i1 + hvar_frag(nh,2)=hfrag(1,j) + hvar_frag(nh,3)=hfrag(2,j) + endif + enddo + + +!v write(iout,'(i4,1pe12.4,1x,1000i1)') +!v & i1,bene(i1),(isec(i),i=1,nres) +!v write(linia,'(i4,1x,1000i1)') +!v & i1,(isec(i),i=1,nres) +!v call write_pdb(i_csa*1000+i1,linia,bene(i1)) +! +! lvar_frag nl==loops; used by N14 +! + i=1 + nl1=nl + do while (i.lt.nres) + if (isec(i).eq.0) then + nl=nl+1 + lvar_frag(nl,1)=i1 + lvar_frag(nl,2)=i + i=i+1 + do while (isec(i).eq.0.and.i.le.nres) + i=i+1 + enddo + lvar_frag(nl,3)=i-1 + if (lvar_frag(nl,3)-lvar_frag(nl,2).lt.1) nl=nl-1 + endif + i=i+1 + enddo +!d write(iout,'(4i5)') (i,(lvar_frag(i,ii),ii=1,3),i=nl1+1,nl) + +! +! svar_frag ns==an secondary structure element; used by N15 +! + i=1 + ns1=ns + do while (i.lt.nres) + if (isec(i).gt.0) then + ns=ns+1 + svar_frag(ns,1)=i1 + svar_frag(ns,2)=i + i=i+1 + do while (isec(i).gt.0.and.isec(i-1).eq.isec(i) & + .and.i.le.nres) + i=i+1 + enddo + svar_frag(ns,3)=i-1 + if (svar_frag(ns,3)-svar_frag(ns,2).lt.1) ns=ns-1 + endif + if (isec(i).eq.0) i=i+1 + enddo +!d write(iout,'(4i5)') (i,(svar_frag(i,ii),ii=1,3),i=ns1+1,ns) + +! +! avar_frag nb==any pair of beta strands; used by N17 +! + do j=1,nbfrag + nb=nb+1 + avar_frag(nb,1)=i1 + do i=1,4 + avar_frag(nb,i+1)=bfrag(i,j) + enddo + enddo + + enddo + + return + end subroutine select_frag +!----------------------------------------------------------------------------- +! together.F +!----------------------------------------------------------------------------- + subroutine together + +! feeds tasks for parallel processing + use MPI_data + use geometry_data + use control_data, only: vdisulf + use energy_data + use io, only:from_int,write_csa_pdb +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! real(kind=4) :: ran1,ran2 +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.TIME1' +! include 'COMMON.SETUP' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.CONTROL' +! include 'COMMON.SBRIDGE' + real(kind=4) :: tcpu + real(kind=8) :: time_start,time_start_c,time0f,time0i + logical :: ovrtim,sync_iter,timeout,flag,timeout1 + integer,dimension(mpi_status_size) :: muster + real(kind=8),dimension(0:100) :: t100 + integer,dimension(mxio) :: indx + real(kind=8),dimension(6*nres) :: xout !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout + integer,dimension(9) :: ind + real(kind=8),dimension(2) :: cout + real(kind=8),parameter :: rad=1.745329252d-2 + + integer :: i,m,j,jlee,nft,idum,nrmsdb,nrmsdb1,ierr,ierror,ierrcode,& + ntrial,ntry,idum2,imax,idumm,nconfr,iconf,mm,k,im,nst,ifar,& + iter,irecv,isent,iw_pdb,nft0i,nft00_c,nft00,ifrom,ij,& + ireq,ireq2 + real(kind=8) :: adif,p_cut,cutdifr,rmsdbc1c,time1i,ctdif1,xctdif,& + time2i,tstart,tend1 +!ccccccccccccccccccccccccccccccccccccccccccccccc + sync_iter=.true. !el + nft=0 !el + time_start=0.0d0 + IF (ME.EQ.KING) THEN + + time0f=MPI_WTIME() + ilastnstep=1 + sync_iter=.false. + numch=1 + nrmsdb=0 + nrmsdb1=0 + rmsdbc1c=rmsdbc1 + nstep=0 + call csa_read + call make_array + + if(iref.ne.0) call from_int(1,0,idum) + +! To minimize input conformation (bank conformation) +! Output to $mol.reminimized + if (irestart.lt.0) then + call read_bank(0,nft,cutdifr) + if (irestart.lt.-10) then + p_cut=nres*4.d0 + call prune_bank(p_cut) + return + endif + call reminimize(jlee) + return + endif + + if (irestart.eq.0) then + call initial_write + nbank=nconf + ntbank=nconf + if (ntbankm.eq.0) ntbank=0 + nstep=0 + nft=0 + do i=1,mxio + ibank(i)=0 + jbank(i)=0 + enddo + else + call restart_write +!!bankt call read_bankt(jlee,nft,cutdifr) + call read_bank(jlee,nft,cutdifr) + call read_rbank(jlee,adif) + if(iref.ne.0) call from_int(1,0,idum) + endif + + nstmax=nstmax+nstep + ntrial=n1+n2+n3+n4+n5+n6+n7+n8 + ntry=ntrial+1 + ntry=ntry*nseed + +! ntrial : number of trial conformations per seed. +! ntry : total number of trial conformations including seed conformations. + + idum2=-123 +! imax=2**31-1 + imax=huge(0) + ENDIF + + call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr) +!ccccccccccccccccccccccccccccccccccccccc + do 300 jlee=1,jend +!ccccccccccccccccccccccccccccccccccccccc + 331 continue + IF (ME.EQ.KING) THEN + if(sync_iter) goto 333 + idum=- ran2(idum2)*imax + if(jlee.lt.jstart) goto 300 + +! Restart the random number generator for conformation generation + + if(irestart.gt.0) then + idum2=idum2+nstep + if(idum2.le.0) idum2=-idum2+1 + idum=- ran2(idum2)*imax + endif + + idumm=idum + call vrndst(idumm) + + open(icsa_seed,file=csa_seed,status="old") + write(icsa_seed,*) "jlee : ",jlee + close(icsa_seed) + + call history_append + write(icsa_history,*) "number of procs is ",nodes + write(icsa_history,*) jlee,idum,idum2 + close(icsa_history) + +!ccccccccccccccccccccccccccccccccccccccccccccccc + 333 icycle=0 + + call history_append + write(icsa_history,*) "nbank is ",nbank + close(icsa_history) + + if(irestart.eq.1) goto 111 + if(irestart.eq.2) then + icycle=0 + do i=1,nbank + ibank(i)=1 + enddo + do i=nbank+1,nbank+nconf + ibank(i)=0 + enddo + endif + +! start energy minimization + nconfr=max0(nconf+nadd,nodes-1) + if (sync_iter) nconf_in=0 +! king-emperor - feed input and sort output + write (iout,*) "NCONF_IN",nconf_in + m=0 + if (nconf_in.gt.0) then +! al 7/2/00 - added possibility to read in some of the initial conformations + do m=1,nconf_in + read (intin,'(i5)',end=11,err=12) iconf + 12 continue + write (iout,*) "write READ_ANGLES",iconf,m + call read_angles(intin,*11) + if (iref.eq.0) then + mm=m + else + mm=m+1 + endif + do j=2,nres-1 + dihang_in(1,j,1,mm)=theta(j+1) + dihang_in(2,j,1,mm)=phi(j+2) + dihang_in(3,j,1,mm)=alph(j) + dihang_in(4,j,1,mm)=omeg(j) + enddo + enddo ! m + goto 13 + 11 write (iout,*) nconf_in," conformations requested, but only",& + m-1," found in the angle file." + nconf_in=m-1 + 13 continue + m=nconf_in + write (iout,*) nconf_in,& + " initial conformations have been read in." + endif + if (iref.eq.0) then + if (nconfr.gt.nconf_in) then + call make_ranvar(nconfr,m,idum) + write (iout,*) nconfr-nconf_in,& + " conformations have been generated randomly." + endif + else + nconfr=nconfr*2 + call from_int(nconfr,m,idum) +! call from_pdb(nconfr,idum) + endif + write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr + write (*,*) 'Exitted from make_ranvar nconfr=',nconfr + do m=1,nconfr + write (iout,*) 'Initial conformation',m + write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1) + write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1) + write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1) + write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1) + enddo + write(iout,*)'Calling FEEDIN NCONF',nconfr + time1i=MPI_WTIME() + call feedin(nconfr,nft) + write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i + call history_append + write(icsa_history,*) jlee,nft,nbank + write(icsa_history,851) (etot(i),i=1,nconfr) + write(icsa_history,850) (rmsn(i),i=1,nconfr) + write(icsa_history,850) (pncn(i),i=1,nconfr) + write(icsa_history,*) + close(icsa_history) + ELSE +! To minimize input conformation (bank conformation) +! Output to $mol.reminimized + if (irestart.lt.0) then + call reminimize(jlee) + return + endif + if (irestart.eq.1) goto 111 +! soldier - perform energy minimization + 334 call minim_jlee + ENDIF + +!cccccccccccccccccccccccccccccccccc +! need to syncronize all procs + call mpi_barrier(CG_COMM,ierr) + if (ierr.ne.0) then + print *, ' cannot synchronize MPI' + stop + endif +!cccccccccccccccccccccccccccccccccc + + IF (ME.EQ.KING) THEN + +! print *,"ok after minim" + nstep=nstep+nconf + if(irestart.eq.2) then + nbank=nbank+nconf +! ntbank=ntbank+nconf + if(ntbank.gt.ntbankm) ntbank=ntbankm + endif +! print *,"ok before indexx" + if(iref.eq.0) then + call indexx(nconfr,etot,indx) + else +! cc/al 7/6/00 + do k=1,nconfr + indx(k)=k + enddo + call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1)) + do k=nconf_in+1,nconfr + indx(k)=indx(k)+nconf_in + enddo +! cc/al +! call indexx(nconfr,rmsn,indx) + endif +! print *,"ok after indexx" + do im=1,nconf + m=indx(im) + if (m.gt.mxio .or. m.lt.1) then + write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + jbank(im+nbank-nconf)=0 + bene(im+nbank-nconf)=etot(m) + rene(im+nbank-nconf)=etot(m) +!!bankt btene(im)=etot(m) +! + brmsn(im+nbank-nconf)=rmsn(m) + bpncn(im+nbank-nconf)=pncn(m) + rrmsn(im+nbank-nconf)=rmsn(m) + rpncn(im+nbank-nconf)=pncn(m) + if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then + write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,& + ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) + rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) +!!bankt btvar(i,j,k,im)=dihang(i,j,k,m) +! + enddo + enddo + enddo + if(iref.eq.1) then + if(brmsn(im+nbank-nconf).gt.rmscut.or. & + bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9 + endif + if(vdisulf) then + bvar_ns(im+nbank-nconf)=ns-2*nss + k=0 + do i=1,ns + j=1 + do while( iss(i).ne.ihpb(j)-nres .and. & + iss(i).ne.jhpb(j)-nres .and. j.le.nss) + j=j+1 + enddo + if (j.gt.nss) then + k=k+1 + bvar_s(k,im+nbank-nconf)=iss(i) + endif + enddo + endif + bvar_nss(im+nbank-nconf)=nss + do i=1,nss + bvar_ss(1,i,im+nbank-nconf)=ihpb(i) + bvar_ss(2,i,im+nbank-nconf)=jhpb(i) + enddo + enddo + ENDIF + + 111 continue + + IF (ME.EQ.KING) THEN + + call find_max + call find_min + + call get_diff + if(nbank.eq.nconf.and.irestart.eq.0) then + adif=avedif + endif + + cutdif=adif/cut1 + ctdif1=adif/cut2 + +!d print *,"adif,xctdif,cutdifr" +!d print *,adif,xctdif,cutdifr + nst=ntotal/ntrial/nseed + xctdif=(cutdif/ctdif1)**(-1.0/nst) + if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr) +! print *,"ok after estimate" + + irestart=0 + + call write_rbank(jlee,adif,nft) + call write_bank(jlee,nft) +!!bankt call write_bankt(jlee,nft) +! call write_bank1(jlee) + call history_append + write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1 + write(icsa_history,851) (bene(i),i=1,nbank) + write(icsa_history,850) (brmsn(i),i=1,nbank) + write(icsa_history,850) (bpncn(i),i=1,nbank) + close(icsa_history) + 850 format(10f8.3) + 851 format(5e15.6) + + ifar=nseed/4*3+1 + ifar=nseed+1 + ENDIF + + + finished=.false. + iter = 0 + irecv = 0 + isent =0 + ifrom= 0 + time0i=MPI_WTIME() + time1i=time0i + time_start_c=time0i + if (.not.sync_iter) then + time_start=time0i + nft00=nft + else + sync_iter=.false. + endif + nft00_c=nft + nft0i=nft + +!cccccccccccccccccccccccccccccccccccccc + do while (.not. finished) +!cccccccccccccccccccccccccccccccccccccc +!rc print *,"iter ", iter,' isent=',isent + + IF (ME.EQ.KING) THEN +! start energy minimization + + if (isent.eq.0) then +! king-emperor - select seeds & make var & feed input +!d print *,'generating new conf',ntrial,MPI_WTIME() + call select_is(nseed,ifar,idum) + + open(icsa_seed,file=csa_seed,status="old") + write(icsa_seed,39) & + jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed) + close(icsa_seed) + call history_append + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& + ebmin,ebmax,nft,iuse,nbank,ntbank + close(icsa_history) + + + + call make_var(ntry,idum,iter) +!d print *,'new trial generated',ntrial,MPI_WTIME() + time2i=MPI_WTIME() + write (iout,'(a20,i4,f12.2)') & + 'Time for make trial',iter+1,time2i-time1i + endif + +!rc write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial +!rc call feedin(ntry,nft) + + isent=isent+1 + if (isent.ge.nodes.or.iter.gt.0) then +!t print *,'waiting ',MPI_WTIME() + irecv=irecv+1 + call recv(0,ifrom,xout,eout,ind,timeout) +!t print *,' ',irecv,' received from',ifrom,MPI_WTIME() + else + ifrom=ifrom+1 + endif + +!t print *,'sending to',ifrom,MPI_WTIME() + call send(isent,ifrom,iter) +!t print *,isent,' sent ',MPI_WTIME() + +! store results ----------------------------------------------- + if (isent.ge.nodes.or.iter.gt.0) then + nft=nft+ind(3) + movernx(irecv)=iabs(ind(5)) + call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) + if(vdisulf) then + nss_out(irecv)=nss + do i=1,nss + iss_out(i,irecv)=ihpb(i) + jss_out(i,irecv)=jhpb(i) + enddo + endif + if(iw_pdb.gt.0) & + call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) + endif +!-------------------------------------------------------------- + if (isent.eq.ntry) then + time1i=MPI_WTIME() + write (iout,'(a18,f12.2,a14,f10.2)') & + 'Nonsetup time ',time1i-time_start_c,& + ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c) + write (iout,'(a14,i4,f12.2,a14,f10.2)') & + 'Time for iter ',iter+1,time1i-time0i,& + ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i) + time0i=time1i + nft0i=nft + cutdif=cutdif*xctdif + if(cutdif.lt.ctdif1) cutdif=ctdif1 + if (iter.eq.0) then + print *,'UPDATING ',ntry-nodes+1,irecv + write(iout,*) 'UPDATING ',ntry-nodes+1 + iter=iter+1 +!----------------- call update(ntry-nodes+1) ------------------- + nstep=nstep+ntry-nseed-(nodes-1) + call refresh_bank(ntry-nodes+1) +!!bankt call refresh_bankt(ntry-nodes+1) + else +!----------------- call update(ntry) --------------------------- + iter=iter+1 + print *,'UPDATING ',ntry,irecv + write(iout,*) 'UPDATING ',ntry + nstep=nstep+ntry-nseed + call refresh_bank(ntry) +!!bankt call refresh_bankt(ntry) + endif +!----------------------------------------------------------------- + + call write_bank(jlee,nft) +!!bankt call write_bankt(jlee,nft) + call find_min + + time1i=MPI_WTIME() + write (iout,'(a20,i4,f12.2)') & + 'Time for refresh ',iter,time1i-time0i + + if(ebmin.lt.estop) finished=.true. + if(icycle.gt.icmax) then + call write_bank1(jlee) + do i=1,nbank + ibank(i)=2 + ibank(i)=1 + enddo + nbank=nbank+nconf + if(nbank.gt.1000) then + finished=.true. + else +!rc goto 333 + sync_iter=.true. + endif + endif + if(nstep.gt.nstmax) finished=.true. + + if(finished.or.sync_iter) then + do ij=1,nodes-1 + call recv(1,ifrom,xout,eout,ind,timeout) + if (timeout) then + nstep=nstep+ij-1 + print *,'ERROR worker is not responding' + write(iout,*) 'ERROR worker is not responding' + time1i=MPI_WTIME()-time_start_c + print *,'End of cycle, master time for ',iter,' iters ',& + time1i,'sec, Eval/s ',(nft-nft00_c)/time1i + write (iout,*) 'End of cycle, master time for ',iter,& + ' iters ',time1i,' sec' + write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i + print *,'UPDATING ',ij-1 + write(iout,*) 'UPDATING ',ij-1 + call flush(iout) + call refresh_bank(ij-1) +!!bankt call refresh_bankt(ij-1) + goto 1002 + endif +! print *,'node ',ifrom,' finished ',ij,nft + write(iout,*) 'node ',ifrom,' finished ',ij,nft + call flush(iout) + nft=nft+ind(3) + movernx(ij)=iabs(ind(5)) + call getx(ind,xout,eout,cout,rad,iw_pdb,ij) + if(vdisulf) then + nss_out(ij)=nss + do i=1,nss + iss_out(i,ij)=ihpb(i) + jss_out(i,ij)=jhpb(i) + enddo + endif + if(iw_pdb.gt.0) & + call write_csa_pdb(xout,eout,nft,ij,iw_pdb) + enddo + nstep=nstep+nodes-1 +!rc print *,'---------bcast finished--------',finished + time1i=MPI_WTIME()-time_start_c + print *,'End of cycle, master time for ',iter,' iters ',& + time1i,'sec, Eval/s ',(nft-nft00_c)/time1i + write (iout,*) 'End of cycle, master time for ',iter,& + ' iters ',time1i,' sec' + write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i + +!timeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) +!timeout call mpi_bcast(sync_iter,1,mpi_logical,0, +!timeout & CG_COMM,ierr) + do ij=1,nodes-1 + tstart=MPI_WTIME() + call mpi_issend(finished,1,mpi_logical,ij,idchar,& + CG_COMM,ireq,ierr) + call mpi_issend(sync_iter,1,mpi_logical,ij,idchar,& + CG_COMM,ireq2,ierr) + flag=.false. + timeout1=.false. + do while(.not. (flag .or. timeout1)) + call MPI_TEST(ireq2,flag,muster,ierr) + tend1=MPI_WTIME() + if(tend1-tstart.gt.60) then + print *,'ERROR worker ',ij,' is not responding' + write(iout,*) 'ERROR worker ',ij,' is not responding' + timeout1=.true. + endif + enddo + if(timeout1) then + write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart + timeout=.true. + else + write(iout,*) 'worker ',ij,' OK ',tend1-tstart + endif + enddo + print *,'UPDATING ',nodes-1,ij + write(iout,*) 'UPDATING ',nodes-1 + call refresh_bank(nodes-1) +!!bankt call refresh_bankt(nodes-1) + 1002 continue + call write_bank(jlee,nft) +!!bankt call write_bankt(jlee,nft) + call find_min + + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + + write(iout,*)'### Total stats:' + do i=0,mxmv + if(nstatnx_tot(i,1).ne.0) then + if (i.le.9) then + write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') & + '### N',i,' total=',nstatnx_tot(i,1),& + ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc',& + (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) + else + write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') & + '###N',i,' total=',nstatnx_tot(i,1),& + ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc',& + (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) + endif + else + if (i.le.9) then + write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') & + '### N',i,' total=',nstatnx_tot(i,1),& + ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),& + ' %acc',0.0 + else + write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') & + '###N',i,' total=',nstatnx_tot(i,1),& + ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),& + ' %acc',0.0 + endif + endif + enddo + + endif + if(sync_iter) goto 331 + + 39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x))) + 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) + 43 format(10i8) + 44 format('jlee =',i3,':',4f10.1,' E =',f8.3,i7,i10) + + isent=0 + irecv=0 + endif + ELSE +! soldier - perform energy minimization + call minim_jlee + print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start + write (iout,*) 'End of minim, proc',me,'time ',& + MPI_WTIME()-time_start + call flush(iout) +!timeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) +!timeout call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr) + call mpi_recv(finished,1,mpi_logical,0,idchar,& + CG_COMM,muster,ierr) + call mpi_recv(sync_iter,1,mpi_logical,0,idchar,& + CG_COMM,muster,ierr) + if(sync_iter) goto 331 + ENDIF + +!cccccccccccccccccccccccccccccccccccccc + enddo +!cccccccccccccccccccccccccccccccccccccc + + IF (ME.EQ.KING) THEN + call history_append + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& + ebmin,ebmax,nft,iuse,nbank,ntbank + + write(icsa_history,44) jlee,0.0,0.0,0.0,& + 0.0,ebmin,nstep,nft + write(icsa_history,*) + close(icsa_history) + + time1i=MPI_WTIME()-time_start + print *,'End of RUN, master time ',& + time1i,'sec, Eval/s ',(nft-nft00)/time1i + write (iout,*) 'End of RUN, master time ',& + time1i,' sec' + write (iout,*) 'Total eval/s ',(nft-nft00)/time1i + + if(timeout) then + write(iout,*) '!!!! ERROR worker was not responding' + write(iout,*) '!!!! cannot finish work normally' + write(iout,*) 'Processor0 is calling MPI_ABORT' + print *,'!!!! ERROR worker was not responding' + print *,'!!!! cannot finish work normally' + print *,'Processor0 is calling MPI_ABORT' + call flush(iout) + call mpi_abort(mpi_comm_world, 111, ierr) + endif + ENDIF + +!ccccccccccccccccccccccccccccc + 300 continue +!ccccccccccccccccccccccccccccc + + return + end subroutine together +!----------------------------------------------------------------------------- + subroutine feedin(nconf,nft) + + use MPI_data + use geometry_data, only:nvar + use io, only:write_csa_pdb +! sends out starting conformations and receives results of energy minimization +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' + include 'mpif.h' + real(kind=8),dimension(6*nres) :: xin,xout !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout + real(kind=8),dimension(2) :: cout + integer,dimension(9) :: ind + integer,dimension(12) :: info + integer,dimension(mpi_status_size) :: muster +! include 'COMMON.SETUP' + real(kind=8),parameter :: rad=1.745329252d-2 + integer :: j,nconf,nft,mm,n,ierror,ierrcode,ierr,iw_pdb,& + man + + print *,'FEEDIN: NCONF=',nconf + mm=0 +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + if (nconf .lt. nodes-1) then + write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1',& + nconf,nodes-1 + write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1',& + nconf,nodes-1 + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do n=1,nconf +! pull out external and internal variables for next start + call putx(xin,n,rad) +! write (iout,*) 'XIN from FEEDIN N=',n +! write(iout,'(8f10.4)') (xin(j),j=1,nvar) + mm=mm+1 + if (mm.lt.nodes) then +! feed task to soldier +! print *, ' sending input for start # ',n + info(1)=n + info(2)=-1 + info(3)=0 + info(4)=0 + info(5)=0 + info(6)=0 + call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,& + ierr) + call mpi_send(xin,nvar,mpi_double_precision,mm,& + idreal,CG_COMM,ierr) + else +! find an available soldier + call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,& + CG_COMM,muster,ierr) +! print *, ' receiving output from start # ',ind(1) + man=muster(mpi_source) +! receive final energies and variables + nft=nft+ind(3) + call mpi_recv(eout,1,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) +! print *,eout +#ifdef CO_BIAS + call mpi_recv(co,1,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) + write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co +#endif + call mpi_recv(xout,nvar,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) +! print *,nvar , ierr +! feed next task to soldier +! print *, ' sending input for start # ',n + info(1)=n + info(2)=-1 + info(3)=0 + info(4)=0 + info(5)=0 + info(6)=0 + info(7)=0 + info(8)=0 + info(9)=0 + call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,& + ierr) + call mpi_send(xin,nvar,mpi_double_precision,man,& + idreal,CG_COMM,ierr) +! retrieve latest results + call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) + if(iw_pdb.gt.0) & + call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) + endif + enddo +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! no more input +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do j=1,nodes-1 +! wait for a soldier + call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,& + CG_COMM,muster,ierr) +!rc if (ierr.ne.0) go to 30 +! print *, ' receiving output from start # ',ind(1) + man=muster(mpi_source) +! receive final energies and variables + nft=nft+ind(3) + call mpi_recv(eout,1,& + mpi_double_precision,man,idreal,& + CG_COMM,muster,ierr) +! print *,eout +#ifdef CO_BIAS + call mpi_recv(co,1,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) + write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co +#endif +!rc if (ierr.ne.0) go to 30 + call mpi_recv(xout,nvar,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) +! print *,nvar , ierr +!rc if (ierr.ne.0) go to 30 +! halt soldier + info(1)=0 + info(2)=-1 + info(3)=0 + info(4)=0 + info(5)=0 + info(6)=0 + call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,& + ierr) +! retrieve results + call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) + if(iw_pdb.gt.0) & + call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) + enddo +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + return + 10 print *, ' dispatching error' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 20 print *, ' communication error' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 30 print *, ' receiving error' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + + return + end subroutine feedin +!----------------------------------------------------------------------------- + subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k) + + use geometry_data + use energy_data + use compare, only: contact_fract + use MPI_data + include 'mpif.h' +! receives and stores data from soldiers +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.CONTACTS' + integer,dimension(9) :: ind + real(kind=8),dimension(6*nres) :: xout !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout +!jlee + real(kind=8) :: przes(3),obr(3,3),cout(2) + logical :: non_conv + integer :: iw_pdb,k,j,ierror,ierrcode + real(kind=8) :: rad,co +!jlee + iw_pdb=2 + if (k.gt.mxio .or. k.lt.1) then + write (iout,*) & + 'ERROR - dimensions of ANGMIN have been exceeded K=',k + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif +! store ind() + do j=1,9 + indb(k,j)=ind(j) + enddo +! store energies + etot(k)=eout(1) +! retrieve dihedral angles etc + call var_to_geom(nvar,xout) + do j=2,nres-1 + dihang(1,j,1,k)=theta(j+1) + dihang(2,j,1,k)=phi(j+2) + dihang(3,j,1,k)=alph(j) + dihang(4,j,1,k)=omeg(j) + enddo + dihang(2,nres-1,1,k)=0.0d0 +!jlee + if(iref.eq.0) then + iw_pdb=1 +!d write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') +!d & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ', +!d & ind(5),ind(4) + return + endif + call chainbuild +! call dihang_to_c(dihang(1,1,1,k)) +! call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv) +! call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv) +! call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup), +! & nsup,przes,obr,non_conv) +! rmsn(k)=dsqrt(rms) + + call rmsd_csa(rmsn(k)) + call contact(.false.,ncont,icont,co) + pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref) + +!d write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5 +!d & ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') +!d & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ', +!d & rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ', +!d & ind(5),ind(4) + + + if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0 + return + end subroutine getx +!----------------------------------------------------------------------------- + subroutine putx(xin,n,rad) + + use geometry_data +! gets starting variables +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' + integer :: n,m,j + real(kind=8),dimension(6*nres) :: xin !(maxvar) (maxvar=6*maxres) + real(kind=8) :: rad + +! pull out starting values for variables +! write (iout,*)'PUTX: N=',n + do m=1,numch +! write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1) +! write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1) +! write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1) +! write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1) + do j=2,nres-1 + theta(j+1)=dihang_in(1,j,m,n) + phi(j+2)=dihang_in(2,j,m,n) + alph(j)=dihang_in(3,j,m,n) + omeg(j)=dihang_in(4,j,m,n) + enddo + enddo +! set up array of variables + call geom_to_var(nvar,xin) +! write (iout,*) 'xin in PUTX N=',n +! call intout +! write (iout,'(8f10.4)') (xin(i),i=1,nvar) + return + end subroutine putx +!----------------------------------------------------------------------------- + subroutine putx2(xin,iff,n) + + use geometry_data +! gets starting variables +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' + integer :: n,m,j,i + real(kind=8),dimension(6*nres) :: xin !(maxvar) (maxvar=6*maxres) + integer,dimension(nres) :: iff !(maxres) + +! pull out starting values for variables + do m=1,numch + do j=2,nres-1 + theta(j+1)=dihang_in2(1,j,m,n) + phi(j+2)=dihang_in2(2,j,m,n) + alph(j)=dihang_in2(3,j,m,n) + omeg(j)=dihang_in2(4,j,m,n) + enddo + enddo +! set up array of variables + call geom_to_var(nvar,xin) + + do i=1,nres + iff(i)=iff_in(i,n) + enddo + return + end subroutine putx2 +!----------------------------------------------------------------------------- + subroutine prune_bank(p_cut) + + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.TIME1' +! include 'COMMON.SETUP' + integer :: k,j,i,m,ip,nprune + real(kind=8) :: p_cut,diff,ddmin +!--------------------------- +! This subroutine prunes bank conformations using p_cut +!--------------------------- + + nprune=0 + nprune=nprune+1 + m=1 + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang(i,j,k,nprune)=bvar(i,j,k,m) + enddo + enddo + enddo + bene(nprune)=bene(m) + brmsn(nprune)=brmsn(m) + bpncn(nprune)=bpncn(m) + + do m=2,nbank + ddmin=9.d190 + do ip=1,nprune + call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) + if(diff.lt.p_cut) goto 100 + if(diff.lt.ddmin) ddmin=diff + enddo + nprune=nprune+1 + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang(i,j,k,nprune)=bvar(i,j,k,m) + enddo + enddo + enddo + bene(nprune)=bene(m) + brmsn(nprune)=brmsn(m) + bpncn(nprune)=bpncn(m) + 100 continue + write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin + enddo + nbank=nprune + print *, 'Pruning :',m,nprune,p_cut + call write_bank(0,0) + + return + end subroutine prune_bank +!----------------------------------------------------------------------------- + subroutine reminimize(jlee) + + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.TIME1' +! include 'COMMON.SETUP' + integer :: i,j,k,jlee,index,nft,ntry +!--------------------------- +! This subroutine re-minimizes bank conformations: +!--------------------------- + + ntry=nbank + + call find_max + call find_min + + if (me.eq.king) then + open(icsa_history,file=csa_history,status="old") + write(icsa_history,*) "Re-minimization",nodes,"nodes" + write(icsa_history,851) (bene(i),i=1,nbank) + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& + ebmin,ebmax,nft,iuse,nbank,ntbank + close(icsa_history) + do index=1,ntry + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,index) + enddo + enddo + enddo + enddo + nft=0 + call feedin(ntry,nft) + else + call minim_jlee + endif + + call find_max + call find_min + + if (me.eq.king) then + do i=1,ntry + call replace_bvar(i,i) + enddo + open(icsa_history,file=csa_history,status="old") + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& + ebmin,ebmax,nft,iuse,nbank,ntbank + write(icsa_history,851) (bene(i),i=1,nbank) + close(icsa_history) + call write_bank_reminimized(jlee,nft) + endif + + 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) + 851 format(5e15.6) + 850 format(5e15.10) +! 850 format(10f8.3) + + return + end subroutine reminimize +!----------------------------------------------------------------------------- + subroutine send(n,mm,it) + + use MPI_data + use geometry_data, only: nvar + use control_data, only: vdisulf +! sends out starting conformation for minimization +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' + include 'mpif.h' + real(kind=8),dimension(6*nres) :: xin,xout,xin2 !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout + real(kind=8),dimension(2) :: cout + integer,dimension(9) :: ind + integer,dimension(nres) :: iff !(maxres) + integer,dimension(12) :: info + integer,dimension(mpi_status_size) :: muster +! include 'COMMON.SETUP' + real(kind=8),parameter :: rad=1.745329252d-2 + integer :: n,mm,it,ierr + + if (isend2(n).eq.0) then +! pull out external and internal variables for next start + call putx(xin,n,rad) + info(1)=n + info(2)=it + info(3)=movenx(n) + info(4)=nss_in(n) + info(5)=parent(1,n) + info(6)=parent(2,n) + + if (movenx(n).eq.14.or.movenx(n).eq.17) then + info(7)=idata(1,n) + info(8)=idata(2,n) + else if (movenx(n).eq.16) then + info(7)=idata(1,n) + info(8)=idata(2,n) + info(10)=idata(3,n) + info(11)=idata(4,n) + info(12)=idata(5,n) + else + info(7)=0 + info(8)=0 + info(10)=0 + info(11)=0 + info(12)=0 + endif + + if (movenx(n).eq.15) then + info(9)=parent(3,n) + else + info(9)=0 + endif + call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,& + ierr) + call mpi_send(xin,nvar,mpi_double_precision,mm,& + idreal,CG_COMM,ierr) + else +! distfit & minimization for n7 move + info(1)=-n + info(2)=it + info(3)=movenx(n) + info(4)=nss_in(n) + info(5)=parent(1,n) + info(6)=parent(2,n) + info(7)=0 + info(8)=0 + info(9)=0 + call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,& + ierr) + call putx2(xin,iff,isend2(n)) + call mpi_send(xin,nvar,mpi_double_precision,mm,& + idreal,CG_COMM,ierr) + call mpi_send(iff,nres,mpi_integer,mm,& + idint,CG_COMM,ierr) + call putx(xin2,n,rad) + call mpi_send(xin2,nvar,mpi_double_precision,mm,& + idreal,CG_COMM,ierr) + endif + if (vdisulf.and.nss_in(n).ne.0) then + call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm,& + idint,CG_COMM,ierr) + call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm,& + idint,CG_COMM,ierr) + endif + return + end subroutine send +!----------------------------------------------------------------------------- + subroutine recv(ihalt,man,xout,eout,ind,tout) + + use MPI_data + use energy_data + use geometry_data, only: nvar + use control_data, only: vdisulf +! receives results of energy minimization +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +! include 'COMMON.SBRIDGE' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' + include 'mpif.h' + real(kind=8),dimension(6*nres) :: xin,xout !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout + real(kind=8),dimension(2) :: cout + integer,dimension(9) :: ind + integer,dimension(12) :: info + integer,dimension(mpi_status_size) :: muster +! include 'COMMON.SETUP' + logical :: tout,flag + real(kind=8) :: tstart,tend1 + real(kind=8),parameter :: twait=600.0d0 + integer :: ihalt,man,ierr + +! find an available soldier + tout=.false. + flag=.false. + tstart=MPI_WTIME() + do while(.not. (flag .or. tout)) + call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, & + muster,ierr) + tend1=MPI_WTIME() + if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true. +!_error if(tend1-tstart.gt.twait) tout=.true. + enddo + if (tout) then + write(iout,*) 'ERROR = timeout for recv ',tend1-tstart + call flush(iout) + return + endif + man=muster(mpi_source) + +!timeout call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, +!timeout * CG_COMM,muster,ierr) +! print *, ' receiving output from start # ',ind(1) +!t print *,'receiving ',MPI_WTIME() +!timeout man=muster(mpi_source) + call mpi_recv(ind,9,mpi_integer,man,idint,& + CG_COMM,muster,ierr) +!timeout +! receive final energies and variables + call mpi_recv(eout,1,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) +! print *,eout +#ifdef CO_BIAS + call mpi_recv(co,1,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) + write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co +#endif + call mpi_recv(xout,nvar,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) +! print *,nvar , ierr + if(vdisulf) nss=ind(6) + if(vdisulf.and.nss.ne.0) then + call mpi_recv(ihpb,nss,mpi_integer,& + man,idint,CG_COMM,muster,ierr) + call mpi_recv(jhpb,nss,mpi_integer,& + man,idint,CG_COMM,muster,ierr) + endif +! halt soldier + if(ihalt.eq.1) then +! print *,'sending halt to ',man + write(iout,*) 'sending halt to ',man + info(1)=0 + call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) + endif + return + end subroutine recv +!----------------------------------------------------------------------------- + subroutine history_append + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + +#if defined(AIX) || defined(PGI) + open(icsa_history,file=csa_history,position="append") +#else + open(icsa_history,file=csa_history,access="append") +#endif + return + end subroutine history_append +!----------------------------------------------------------------------------- + subroutine alloc_CSA_arrays + + use energy_data, only: ns + + mxgr=2*nres + + if(.not.allocated(bfrag)) allocate(bfrag(4,nres/3)) +! commom.bank +! common/varin/ +!el allocate(dihang_in(mxang,nres,mxch,mxio)) !(mxang,maxres,mxch,mxio) + allocate(dihang_in(mxang,nres,mxch,5000)) !(mxang,maxres,mxch,mxio) + allocate(nss_in(mxio)) !(mxio) + allocate(iss_in(ns,mxio),jss_in(ns,mxio)) !(maxss,mxio) +! common/minvar/ + allocate(dihang(mxang,nres,mxch,mxio)) !(mxang,maxres,mxch,mxio) + allocate(rmsn(mxio),pncn(mxio)) !(mxio) + allocate(etot(mxio)) !(mxio) + allocate(nss_out(mxio)) !(mxio) + allocate(iss_out(ns,mxio),jss_out(ns,mxio)) !(maxss,mxio) +! common/bank/ + allocate(rvar(mxang,nres,mxch,mxio),bvar(mxang,nres,mxch,mxio)) !(mxang,maxres,mxch,mxio) + allocate(bene(mxio),rene(mxio),brmsn(mxio),rrmsn(mxio)) + allocate(bpncn(mxio),rpncn(mxio)) !(mxio) + allocate(ibank(mxio),is(mxio),jbank(mxio)) !(mxio) + allocate(dij(mxio,mxio)) !(mxio,mxio) +! common/bank_disulfid/ + allocate(bvar_nss(mxio),bvar_ns(mxio)) !(mxio) + allocate(bvar_s(ns,mxio)) !(maxss,mxio) + allocate(bvar_ss(2,ns,mxio)) !(2,maxss,mxio) +! common/mvstat/ + allocate(movenx(mxio),movernx(mxio)) !(mxio) + allocate(nstatnx(0:mxmv,3),nstatnx_tot(0:mxmv,3)) !(0:mxmv,3) + allocate(indb(mxio,9)) !(mxio,9) + allocate(parent(3,mxio)) !(3,mxio) +! common/send2/ + allocate(isend2(mxio)) !(mxio) + allocate(iff_in(nres,mxio2)) !(maxres,mxio2) + allocate(dihang_in2(mxang,nres,mxch,mxio2)) !(mxang,maxres,mxch,mxio2) + allocate(idata(5,mxio)) !(5,mxio) +! common.csa +! common/alphaa/ + allocate(ngroup(mxgr)) !(mxgr) + allocate(igroup(3,mxang,mxgr)) !(3,mxang,mxgr) +! common.distfit +! COMMON /frag/ + allocate(bvar_frag(mxio,6)) !(mxio,6) + allocate(hvar_frag(mxio,3),lvar_frag(mxio,3),svar_frag(mxio,3)) !(mxio,3) + allocate(avar_frag(mxio,5)) !(mxio,5) +! commom.hairpin +! common /spinka/ + allocate(nharp_seed(nseed),nharp_use(nseed)) !(max_seed) + allocate(iharp_seed(4,nres/3,nseed)) !(4,maxres/3,max_seed) + allocate(iharp_use(0:4,nres/3,nseed)) !(0:4,maxres/3,max_seed) + + return + end subroutine alloc_CSA_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module csa diff --git a/source/unres/CSA.f90 b/source/unres/CSA.f90 deleted file mode 100644 index 66b98ee..0000000 --- a/source/unres/CSA.f90 +++ /dev/null @@ -1,5321 +0,0 @@ - module csa -!----------------------------------------------------------------------------- - use io_units - use names - use math - use random - use geometry_data, only: nres,rad2deg - use geometry - use energy - use MPI_ - use csa_data - use compare - use io_config - - implicit none -!----------------------------------------------------------------------------- -! commom.bank -! common/varin/ -! real(kind=8),dimension(:,:,:,:),allocatable :: dihang_in !(mxang,maxres,mxch,mxio) - integer,dimension(:),allocatable :: nss_in !(mxio) - integer,dimension(:,:),allocatable :: iss_in,jss_in !(maxss,mxio) -! common/minvar/ - real(kind=8),dimension(:,:,:,:),allocatable :: dihang !(mxang,maxres,mxch,mxio) - real(kind=8),dimension(:),allocatable :: etot!,rmsn,pncn !(mxio) - integer,dimension(:),allocatable :: nss_out !(mxio) - integer,dimension(:,:),allocatable ::iss_out,jss_out !(maxss,mxio) -! common/bank/ -! real(kind=8),dimension(:,:,:,:),allocatable :: bvar !(mxang,maxres,mxch,mxio) -! real(kind=8),dimension(:),allocatable :: bene,rene,& -! brmsn,rrmsn,bpncn,rpncn !(mxio) - integer,dimension(:),allocatable :: is,jbank !(mxio) - real(kind=8) :: avedif,difmin,ebmin,ebmax,ebmaxt!,& -! dele,difcut,cutdif,rmscut,pnccut - real(kind=8),dimension(:,:),allocatable :: dij !(mxio,mxio) -! common/bank_disulfid/ -! common/mvstat/ - integer,dimension(:),allocatable :: movenx,movernx !(mxio) - integer,dimension(:,:),allocatable :: nstatnx,nstatnx_tot !(0:mxmv,3) - integer,dimension(:,:),allocatable :: indb !(mxio,9) - integer,dimension(:,:),allocatable :: parent !(3,mxio) -! common/send2/ - integer,dimension(:),allocatable :: isend2 !(mxio) - integer,dimension(:,:),allocatable :: iff_in !(maxres,mxio2) - integer,dimension(:,:,:,:),allocatable :: dihang_in2 !(mxang,maxres,mxch,mxio2) - integer,dimension(:,:),allocatable :: idata !(5,mxio) -!----------------------------------------------------------------------------- -! common.csa -! integer :: irestart,ndiff -! common/alphaa/ - integer,dimension(:),allocatable :: ngroup !(mxgr) - integer,dimension(:,:,:),allocatable :: igroup !(3,mxang,mxgr) - integer :: ntotgr!,numch -! common/csa_input/ -! common/dih_control/ -! real(kind=8) :: rdih_bias - logical :: ldih_bias -!----------------------------------------------------------------------------- -! common.distfit -! COMMON /frag/ - integer,dimension(:,:),allocatable :: bvar_frag !(mxio,6) - integer,dimension(:,:),allocatable :: hvar_frag,lvar_frag,svar_frag !(mxio,3) - integer,dimension(:,:),allocatable :: avar_frag !(mxio,5) -!----------------------------------------------------------------------------- -! commom.hairpin -! common /spinka/ - integer :: nharp_tot - integer,dimension(:),allocatable :: nharp_seed,nharp_use !(max_seed) - integer,dimension(:,:,:),allocatable :: iharp_seed !(4,maxres/3,max_seed) - integer,dimension(:,:,:),allocatable :: iharp_use !(0:4,maxres/3,max_seed) -!----------------------------------------------------------------------------- -! Maximum number of moves (n1-n8) - integer,parameter :: mxmv=18 -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! bank.F -!----------------------------------------------------------------------------- - subroutine refresh_bank(ntrial) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.CONTROL' - character :: chacc - integer :: iaccn,ntrial - real(kind=8) :: l_diff(mxio),denep - integer :: i,j,n,m,i1,idmin - real(kind=8) :: del_ene - - do i=0,mxmv - do j=1,3 - nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) - nstatnx(i,j)=0 - enddo - enddo - -! loop over all newly obtained conformations - do n=1,ntrial - chacc=' ' - iaccn=0 - nstatnx(movernx(n),1)=nstatnx(movernx(n),1)+1 -!ccccccccccccccccccccccccccccccccccccccccccc -!jlee - if(iref.ne.0) then - if(rmsn(n).gt.rmscut.or.pncn(n).lt.pnccut) goto 100 - endif -!jlee - if(etot(n).gt.ebmax) goto 100 -! Find the conformation closest to the conformation n in the bank - difmin=9.d9 - do m=1,nbank - call get_diff12(dihang(1,1,1,n),bvar(1,1,1,m),l_diff(m)) - if(l_diff(m).lt.difmin) then - difmin=l_diff(m) - idmin=m - endif - enddo - - if(difmin.lt.cutdif) then -! n is redundant to idmin - if(etot(n).lt.bene(idmin)) then - if(etot(n).lt.bene(idmin)-0.01d0) then - ibank(idmin)=0 - jbank(idmin)=0 - endif - denep=bene(idmin)-etot(n) - call replace_bvar(idmin,n) -!rc Update dij - do i1=1,nbank - if (i1.ne.idmin) then - dij(i1,idmin)=l_diff(i1) - dij(idmin,i1)=l_diff(i1) - endif - enddo - chacc='c' - iaccn=idmin - nstatnx(movernx(n),2)=nstatnx(movernx(n),2)+1 - if(idmin.eq.ibmax) call find_max - endif - else -! got new conformation - del_ene=0.0d0 - if(ebmax-ebmin.gt.del_ene) then - denep=ebmax-etot(n) - call replace_bvar(ibmax,n) -!rc Update dij - do i1=1,nbank - if (i1.ne.ibmax) then - dij(i1,ibmax)=l_diff(i1) - dij(ibmax,i1)=l_diff(i1) - endif - enddo - chacc='f' - iaccn=ibmax - nstatnx(movernx(n),3)=nstatnx(movernx(n),3)+1 - ibank(ibmax)=0 - jbank(ibmax)=0 - call find_max - else - if(del_ene.lt.0.0001) then - write (iout,*) 'ERROR in refresh_bank: ' - write (iout,*) 'ebmax: ',ebmax - write (iout,*) 'ebmin: ',ebmin - write (iout,*) 'del_ene: ',del_ene -!rc call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -!jp nbmax is never defined so condition below is always false -! if(nbank.lt.nbmax) then -! nbank=nbank+1 -! call replace_bvar(nbank,n) -! ibank(nbank)=0 -! jbank(nbank)=0 -! else - call replace_bvar(ibmax,n) - ibank(ibmax)=0 - jbank(ibmax)=0 - call find_max -! endif - endif - endif -!ccccccccccccccccccccccccccccccccccccccccccc - 100 continue - if (iaccn.eq.0) then - if (iref.eq.0) then - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5)') & - indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& - indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9) - else - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5,0pf4.1,a5,f3.0)') & - indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& - indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9),& - ' rms ',rmsn(n),' %NC ',pncn(n)*100 - endif - else - if (iref.eq.0) then - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,1x,a1,i4,0pf8.1,0pf8.1)') & - indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& - indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9),& - chacc,iaccn,difmin,denep - else - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5,0pf4.1,a5,f3.0,1x,a1,i4,0pf8.1,0pf8.1)') & - indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ',& - indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9),& - ' rms ',rmsn(n),' %NC ',pncn(n)*100,& - chacc,iaccn,difmin,denep - endif - endif - enddo -! end of loop over all newly obtained conformations - do i=0,mxmv - if(nstatnx(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') & - '## N',i,' total=',nstatnx(i,1),& - ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& - ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') & - '##N',i,' total=',nstatnx(i,1),& - ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& - ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - endif - else - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') & - '## N',i,' total=',nstatnx(i,1),& - ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& - ' %acc',0.0 - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') & - '##N',i,' total=',nstatnx(i,1),& - ' close=',nstatnx(i,2),' far=',nstatnx(i,3),& - ' %acc',0.0 - endif - endif - enddo - call flush(iout) -!rc Update dij -!rc moved up, saves some get_diff12 calls -!rc -!rc do i1=1,nbank-1 -!rc do i2=i1+1,nbank -!rc if(jbank(i1).eq.0.or.jbank(i2).eq.0) then -!rc call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) -!rc dij(i1,i2)=diff -!rc dij(i2,i1)=diff -!rc endif -!rc enddo -!rc enddo - - do i=1,nbank - jbank(i)=1 - enddo - - return - end subroutine refresh_bank -!----------------------------------------------------------------------------- - subroutine replace_bvar(iold,inew) - - use control_data, only: vdisulf - use energy_data, only: ns,iss -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.CONTROL' -! include 'COMMON.SBRIDGE' - integer :: iold,inew,ierror,ierrcode,i,j,k - - if (iold.gt.mxio .or. iold.lt.1 .or. inew.gt.mxio .or. inew.lt.1) & - then - write (iout,*) 'Dimension ERROR in REPLACE_BVAR: IOLD',iold,& - ' INEW',inew - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,iold)=dihang(i,j,k,inew) - enddo - enddo - enddo - bene(iold)=etot(inew) - brmsn(iold)=rmsn(inew) - bpncn(iold)=pncn(inew) - - if(bene(iold).lt.ebmin) then - ebmin=bene(iold) - ibmin=iold - endif - - if(vdisulf) then - bvar_nss(iold)=nss_out(inew) -!d write(iout,*) 'SS BANK',iold,bvar_nss(iold) - do i=1,bvar_nss(iold) - bvar_ss(1,i,iold)=iss_out(i,inew) - bvar_ss(2,i,iold)=jss_out(i,inew) -!d write(iout,*) 'SS',bvar_ss(1,i,iold)-nres, -!d & bvar_ss(2,i,iold)-nres - enddo - - bvar_ns(iold)=ns-2*bvar_nss(iold) -!d write(iout,*) 'CYS #free ', bvar_ns(iold) - k=0 - do i=1,ns - j=1 - do while( iss(i).ne.iss_out(j,inew)-nres .and. & - iss(i).ne.jss_out(j,inew)-nres .and. & - j.le.nss_out(inew)) - j=j+1 - enddo - if (j.gt.nss_out(inew)) then - k=k+1 - bvar_s(k,iold)=iss(i) - endif - enddo -!d write(iout,*) 'CYS free',(bvar_s(k,iold),k=1,bvar_ns(iold)) - endif - - return - end subroutine replace_bvar -!----------------------------------------------------------------------------- - subroutine save_is(ind) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' - integer :: ind,i,j,k,index,ierror,ierrcode - - index=nbank+ind -! print *, "nbank,ind,index,is(ind) ",nbank,ind,index,is(ind) - if (index.gt.mxio .or. index.lt.1 .or. & - is(ind).gt.mxio .or. is(ind).lt.1) then - write (iout,*) 'Dimension ERROR in SAVE_IS: INDEX',index,& - ' IND',ind,' IS',is(ind) - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,index)=bvar(i,j,k,is(ind)) - enddo - enddo - enddo - bene(index)=bene(is(ind)) - ibank(is(ind))=1 - - return - end subroutine save_is -!----------------------------------------------------------------------------- - subroutine select_is(n,ifar,idum) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer,dimension(mxio) :: itag - real(kind=8),dimension(mxio) :: adiff - integer :: n,ifar,idum,i,iusesv,imade - - iuse=0 - do i=1,nbank - if(ibank(i).eq.0) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iusesv=iuse - - if(iuse.eq.0) then - icycle=icycle+1 - do i=1,nbank - if(ibank(i).eq.2) then - ibank(i)=1 - else - ibank(i)=0 - endif - enddo - imade=0 - call get_is(idum,ifar,n,imade,0) -!test3 call get_is_max(idum,ifar,n,imade,0) - else if(iuse.eq.n) then - do i=1,iuse - is(i)=itag(i) - call save_is(i) - enddo - else if(iuse.lt.n) then -! if(icycle.eq.0) then -! do i=1,n -! ind=mod(i-1,iuse)+1 -! is(i)=itag(ind) -! call save_is(i) -! enddo -! else -! endif - do i=1,iuse - is(i)=itag(i) - call save_is(i) - enddo - imade=iuse -! call get_is_ran(idum,n,imade,1) - call get_is(idum,ifar,n,imade,1) -!test3 call get_is_max(idum,ifar,n,imade,1) -! if(iusesv.le.n/10) then - if(iusesv.le.0) then - icycle=icycle+1 - do i=1,nbank -! if(ibank(i).eq.2) then -! ibank(i)=1 - if(ibank(i).ge.2) then - ibank(i)=ibank(i)-1 - else - ibank(i)=0 - endif - enddo - endif - else - imade=0 - call get_is(idum,ifar,n,imade,0) -!test3 call get_is_max(idum,ifar,n,imade,0) - endif - iuse=iusesv - - return - end subroutine select_is -!----------------------------------------------------------------------------- - subroutine get_is_ran(idum,n,imade,k) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! real(kind=4) :: ran1,ran2 - integer,dimension(mxio) :: itag - real(kind=8),dimension(mxio) :: adiff - integer :: idum,n,imade,k,j,i,iran - - do j=imade+1,n - iuse=0 - do i=1,nbank - if(ibank(i).eq.k) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iran=iuse* ran1(idum)+1 - is(j)=itag(iran) - call save_is(j) - enddo - - return - end subroutine get_is_ran -!----------------------------------------------------------------------------- - subroutine get_is(idum,ifar,n,imade,k) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! real(kind=4) :: ran1,ran2 - integer,dimension(mxio) :: itag - real(kind=8),dimension(mxio) :: adiff - integer :: idum,ifar,n,imade,k,i,iran - - iuse=0 - do i=1,nbank - if(ibank(i).eq.k) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iran=iuse* ran1(idum)+1 - imade=imade+1 - is(imade)=itag(iran) - call save_is(imade) - - do i=imade+1,ifar-1 - if(icycle.eq.-1) then - call select_iseed_max(i,k) - else - call select_iseed_min(i,k) -!test4 call select_iseed_max(i,k) - endif - call save_is(i) - enddo - - do i=ifar,n - call select_iseed_far(i,k) - call save_is(i) - enddo - - return - end subroutine get_is -!----------------------------------------------------------------------------- - subroutine select_iseed_max(imade1,ik) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer,dimension(mxio) :: itag - real(kind=8),dimension(mxio) :: adiff - integer :: imade1,ik,i,n,imade,m,itagi - real(kind=8) :: difmax,diff,emax,benei,diffmn - - iuse=0 - avedif=0.d0 - difmax=0.d0 - do n=1,nbank - if(ibank(n).eq.ik) then - iuse=iuse+1 - diffmn=9.d190 - do imade=1,imade1-1 -! m=nbank+imade -! call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - if(diffmn.gt.difmax) difmax=diffmn - adiff(iuse)=diffmn - itag(iuse)=n - avedif=avedif+diffmn - endif - enddo - - avedif=avedif/iuse -! avedif=(avedif+difmax)/2 - emax=-9.d190 - do i=1,iuse - if(adiff(i).ge.avedif) then - itagi=itag(i) - benei=bene(itagi) - if(benei.gt.emax) then - emax=benei - is(imade1)=itagi - endif - endif - enddo - - if(ik.eq.0) iuse=iuse-1 - - return - end subroutine select_iseed_max -!----------------------------------------------------------------------------- - subroutine select_iseed_min(imade1,ik) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer,dimension(mxio) :: itag - real(kind=8),dimension(mxio) :: adiff - integer :: imade1,ik,n,imade,m,i,itagi - real(kind=8) :: difmax,diff,diffmn,emin,benei - - iuse=0 - avedif=0.d0 - difmax=0.d0 - do n=1,nbank - if(ibank(n).eq.ik) then - iuse=iuse+1 - diffmn=9.d190 - do imade=1,imade1-1 -! m=nbank+imade -! call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - if(diffmn.gt.difmax) difmax=diffmn - adiff(iuse)=diffmn - itag(iuse)=n - avedif=avedif+diffmn - endif - enddo - - avedif=avedif/iuse -! avedif=(avedif+difmax)/2 - emin=9.d190 - do i=1,iuse -! print *,"i, adiff(i),avedif : ",i,adiff(i),avedif - if(adiff(i).ge.avedif) then - itagi=itag(i) - benei=bene(itagi) -! print *,"i, benei,emin : ",i,benei,emin - if(benei.lt.emin) then - emin=benei - is(imade1)=itagi - endif - endif - enddo - - if(ik.eq.0) iuse=iuse-1 - -! print *, "exiting select_iseed_min",is(imade1) - - return - end subroutine select_iseed_min -!----------------------------------------------------------------------------- - subroutine select_iseed_far(imade1,ik) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer :: imade1,ik,n,imade,m - real(kind=8) :: dmax,diffmn,diff - - dmax=-9.d190 - do n=1,nbank - if(ibank(n).eq.ik) then - diffmn=9.d190 - do imade=1,imade1-1 -! m=nbank+imade -! call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - endif - if(diffmn.gt.dmax) then - dmax=diffmn - is(imade1)=n - endif - enddo - - return - end subroutine select_iseed_far -!----------------------------------------------------------------------------- - subroutine find_min - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer :: i - real(kind=8) :: benei - - ebmin=9.d190 - - do i=1,nbank - benei=bene(i) - if(benei.lt.ebmin) then - ebmin=benei - ibmin=i - endif - enddo - - return - end subroutine find_min -!----------------------------------------------------------------------------- - subroutine find_max - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer :: i - real(kind=8) :: benei - - ebmax=-9.d190 - - do i=1,nbank - benei=bene(i) - if(benei.gt.ebmax) then - ebmax=benei - ibmax=i - endif - enddo - - return - end subroutine find_max -!----------------------------------------------------------------------------- - subroutine get_diff - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer :: i,i1,i2 - real(kind=8) :: tdiff,difmin,diff - - tdiff=0.d0 - difmin=9.d190 - do i1=1,nbank-1 - do i2=i1+1,nbank - if(jbank(i1).eq.0.or.jbank(i2).eq.0) then - call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) - dij(i1,i2)=diff - dij(i2,i1)=diff - else - diff=dij(i1,i2) - endif - tdiff=tdiff+diff - if(diff.lt.difmin) difmin=diff - enddo - dij(i1,i1)=0.0 - enddo - - do i=1,nbank - jbank(i)=1 - enddo - - avedif=tdiff/nbank/(nbank-1)*2 - - return - end subroutine get_diff -!----------------------------------------------------------------------------- - subroutine estimate_cutdif(adif,xct,cutdifr) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer :: nexp - real(kind=8) :: adif,xct,cutdifr,ctdif1,exponent - - ctdif1=adif/cut2 - - exponent = cutdifr*cut1/adif - exponent = dlog(exponent)/dlog(xct) - - nexp=exponent+0.25 - cutdif= adif/cut1*xct**nexp - if(cutdif.lt.ctdif1) cutdif=ctdif1 - - return - end subroutine estimate_cutdif -!----------------------------------------------------------------------------- - subroutine get_is_max(idum,ifar,n,imade,k) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' - integer :: idum,ifar,n,imade,k,i,j - real(kind=8) :: emax - - do i=imade+1,n - emax=-9.d190 - do j=1,nbank - if(ibank(j).eq.k .and. bene(j).gt.emax) then - emax=bene(j) - is(i)=j - endif - enddo - call save_is(i) - enddo - - return - end subroutine get_is_max -!----------------------------------------------------------------------------- -! csa.f -!----------------------------------------------------------------------------- - subroutine make_array - - use energy_data, only: itype -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.CSA' - integer :: k,j,i,indg -!cccccccccccccccccccccccc -! Level-2: group -!cccccccccccccccccccccccc - - indg=0 - do k=1,numch -!cccccccccccccccccccccccccccccccccccccccc -! Groups the THETAs and the GAMMAs - do j=2,nres-1 - indg=indg+1 - if (j.lt.nres-1) then - ngroup(indg)=2 - else - ngroup(indg)=1 - endif - do i=1,ngroup(indg) - igroup(1,i,indg)=i - igroup(2,i,indg)=j - igroup(3,i,indg)=k - enddo - enddo -!cccccccccccccccccccccccccccccccccccccccc - enddo -! Groups the ALPHAs and the BETAs - do k=1,numch - do j=2,nres-1 - if(itype(j).ne.10) then - indg=indg+1 - ngroup(indg)=2 - do i=1,ngroup(indg) - igroup(1,i,indg)=i+2 - igroup(2,i,indg)=j - igroup(3,i,indg)=k - enddo - endif - enddo - enddo - - ntotgr=indg - write(iout,*) - write(iout,*) "# of groups: ",ntotgr - do i=1,ntotgr - write(iout,41) i,ngroup(i),((igroup(k,j,i),k=1,3),j=1,ngroup(i)) - enddo -! close(iout) - - 40 format(i3,3x,3i3) - 41 format(2i3,3x,6(3i3,2x)) - - return - end subroutine make_array -!----------------------------------------------------------------------------- - subroutine make_ranvar(n,m,idum) - - use geometry_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.BANK' - integer :: n,m,j,idum,itrial,jeden - -! al m=0 - print *,'HOHOHOHO Make_RanVar!!!!!',n,m - itrial=0 - do while(m.lt.n .and. itrial.le.10000) - itrial=itrial+1 - jeden=1 - call gen_rand_conf(jeden,*10) -! call intout - m=m+1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - goto 20 - 10 write (iout,*) 'Failed to generate conformation #',m+1,& - ' itrial=',itrial - 20 continue - enddo - print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial - - return - end subroutine make_ranvar -!----------------------------------------------------------------------------- - subroutine make_ranvar_reg(n,idum) - - use geometry_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.BANK' -! include 'COMMON.GEO' - integer :: n,idum,j,m,itrial,jeden - - m=0 - print *,'HOHOHOHO Make_RanVar!!!!!' - itrial=0 - do while(m.lt.n .and. itrial.le.10000) - itrial=itrial+1 - jeden=1 - call gen_rand_conf(jeden,*10) -! call intout - m=m+1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - if(m.le.n*0.1) then - dihang_in(1,j,1,m)=90.0*deg2rad - dihang_in(2,j,1,m)=50.0*deg2rad - endif - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - goto 20 - 10 write (iout,*) 'Failed to generate conformation #',m+1,& - ' itrial=',itrial - 20 continue - enddo - print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial - - return - end subroutine make_ranvar_reg -!----------------------------------------------------------------------------- -! diff12.f -!----------------------------------------------------------------------------- - subroutine get_diff12(aarray,barray,diff) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - integer :: k,j,i - real(kind=8),dimension(mxang,nres,mxch) :: aarray,barray !(mxang,maxres,mxch) - real(kind=8) :: diff,dif - - diff=0.d0 - do k=1,numch - do j=2,nres-1 -! do i=1,4 -! do i=1,2 - do i=1,ndiff - dif=rad2deg*dabs(aarray(i,j,k)-barray(i,j,k)) - if(dif.gt.180.) dif=360.-dif - if (dif.gt.diffcut) diff=diff+dif - enddo - enddo - enddo - - return - end subroutine get_diff12 -!----------------------------------------------------------------------------- -! indexx.f -!----------------------------------------------------------------------------- - subroutine indexx(n,arr,indx) - -! implicit real*8 (a-h,o-z) - INTEGER :: n,indx(n) - REAL(kind=8) :: arr(n) -! PARAMETER (M=7,NSTACK=50) - integer,PARAMETER :: M=7,NSTACK=500 - INTEGER :: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - REAL(kind=8) :: a - - do 11 j=1,n - indx(j)=j -11 continue - jstack=0 - l=1 - ir=n -1 if(ir-l.lt.M)then - do 13 j=l+1,ir - indxt=indx(j) - a=arr(indxt) - do 12 i=j-1,1,-1 - if(arr(indx(i)).le.a)goto 2 - indx(i+1)=indx(i) -12 continue - i=0 -2 indx(i+1)=indxt -13 continue - if(jstack.eq.0)return - ir=istack(jstack) - l=istack(jstack-1) - jstack=jstack-2 - else - k=(l+ir)/2 - itemp=indx(k) - indx(k)=indx(l+1) - indx(l+1)=itemp - if(arr(indx(l+1)).gt.arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l)).gt.arr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1)).gt.arr(indx(l)))then - itemp=indx(l+1) - indx(l+1)=indx(l) - indx(l)=itemp - endif - i=l+1 - j=ir - indxt=indx(l) - a=arr(indxt) -3 continue - i=i+1 - if(arr(indx(i)).lt.a)goto 3 -4 continue - j=j-1 - if(arr(indx(j)).gt.a)goto 4 - if(j.lt.i)goto 5 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp - goto 3 -5 indx(l)=indx(j) - indx(j)=indxt - jstack=jstack+2 - if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' - if(ir-i+1.ge.j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i - endif - endif - goto 1 - end subroutine indexx -! (C) Copr. 1986-92 Numerical Recipes Software *11915aZ%. -!----------------------------------------------------------------------------- -! minim_jlee.F -!----------------------------------------------------------------------------- - subroutine minim_jlee - - use minim_data - use MPI_data - use energy_data - use compare_data - use control_data - use geometry_data, only: nvar,nphi - use geometry, only:dist - use energy, only:fdum - use control, only:init_int_table - use minimm, only:sumsl,deflt -! controls minimization and sorting routines -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.MINIM' -! include 'COMMON.CONTROL' - include 'mpif.h' - integer,parameter :: liv=60 - integer :: lv -! external func,gradient!,fdum !use minim & energy -! real(kind=4) :: ran1,ran2,ran3 -! include 'COMMON.SETUP' -! include 'COMMON.GEO' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.DISTFIT' -! include 'COMMON.CHAIN' - integer,dimension(mpi_status_size) :: muster - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: erg - real(kind=8),dimension(6*nres) :: var2 !(maxvar) (maxvar=6*maxres) - integer,dimension(nres) :: iffr !(maxres) - integer,dimension((nres-1)*(nres-2)/2) :: ihpbt,jhpbt !(maxdim) (maxdim=(maxres-1)*(maxres-2)/2) - real(kind=8),dimension(6*nres) :: d,garbage !(maxvar) (maxvar=6*maxres) -!el real(kind=8),dimension(1:lv+1) :: v - real(kind=8) :: energia(0:n_ene),time0s,time1s - integer,dimension(9) :: indx - integer,dimension(12) :: info - integer,dimension(liv) :: iv - integer :: idum(1) - real(kind=8) :: rdum(1) - integer,dimension(2,12*nres) :: icont_ !(2,maxcont)(maxcont=12*maxres) - logical :: fail !check_var, - integer :: iloop(2) -!el common /przechowalnia/ v - integer :: i,j,ierr,n,nfun,nft_sc,nf,ierror,ierrcode - real(kind=8) :: rad,eee,etot !,fdum -!el from subroutine parmread -! Define the constants of the disulfide bridge -! Old arbitrary potential - real(kind=8),parameter :: dbr=4.20D0 - real(kind=8),parameter :: fbr=3.30D0 -!----------------- - lv=77+(6*nres)*(6*nres+17)/2 !77+maxvar*(maxvar+17)/2 (maxvar=6*maxres) - data rad /1.745329252d-2/ -! receive # of start -! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, -! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf - if (.not. allocated(v)) allocate(v(1:lv)) - nhpb0=nhpb - 10 continue - time0s=MPI_WTIME() -! print *, 'MINIM_JLEE: ',me,' is waiting' - call mpi_recv(info,12,mpi_integer,king,idint,CG_COMM,& - muster,ierr) - time1s=MPI_WTIME() - write (iout,'(a12,f10.4,a4)')'Waiting for ',time1s-time0s,' sec' - call flush(iout) - n=info(1) -! print *, 'MINIM_JLEE: ',me,' received: ',n - -!rc if (ierr.ne.0) go to 100 -! if # = 0, return - if (n.eq.0) then - write (iout,*) 'Finishing minim_jlee - signal',n,' from master' - call flush(iout) - return - endif - - nfun=0 - IF (n.lt.0) THEN - call mpi_recv(var,nvar,mpi_double_precision,& - king,idreal,CG_COMM,muster,ierr) - call mpi_recv(iffr,nres,mpi_integer,& - king,idint,CG_COMM,muster,ierr) - call mpi_recv(var2,nvar,mpi_double_precision,& - king,idreal,CG_COMM,muster,ierr) - ELSE -! receive initial values of variables - call mpi_recv(var,nvar,mpi_double_precision,& - king,idreal,CG_COMM,muster,ierr) -!rc if (ierr.ne.0) go to 100 - ENDIF - - if(vdisulf.and.info(2).ne.-1) then - if(info(4).ne.0)then - call mpi_recv(ihpbt,info(4),mpi_integer,& - king,idint,CG_COMM,muster,ierr) - call mpi_recv(jhpbt,info(4),mpi_integer,& - king,idint,CG_COMM,muster,ierr) - endif - endif - - IF (n.lt.0) THEN - n=-n - nhpb=nhpb0 - link_start=1 - link_end=nhpb - call init_int_table - call contact_cp(var,var2,iffr,nfun,n) - ENDIF - - if(vdisulf.and.info(2).ne.-1) then - nss=0 - if(info(4).ne.0)then -!d write(iout,*) 'SS=',info(4),'N=',info(1),'IT=',info(2) - call var_to_geom(nvar,var) - call chainbuild - do i=1,info(4) - if (dist(ihpbt(i),jhpbt(i)).lt.7.0) then - nss=nss+1 - ihpb(nss)=ihpbt(i) - jhpb(nss)=jhpbt(i) -!d write(iout,*) 'SS mv=',info(3), -!d & ihpb(nss)-nres,jhpb(nss)-nres, -!d & dist(ihpb(nss),jhpb(nss)) - dhpb(nss)=dbr - forcon(nss)=fbr - else -!d write(iout,*) 'rm SS mv=',info(3), -!d & ihpbt(i)-nres,jhpbt(i)-nres,dist(ihpbt(i),jhpbt(i)) - endif - enddo - endif - nhpb=nss - link_start=1 - link_end=nhpb - call init_int_table - endif - - if (info(3).eq.14) then - write(iout,*) 'calling local_move',info(7),info(8) - call local_move_init(.false.) - call var_to_geom(nvar,var) - call local_move(info(7),info(8),20d0,50d0) - call geom_to_var(nvar,var) - endif - - - if (info(3).eq.16) then - write(iout,*) 'calling beta_slide',info(7),info(8),& - info(10), info(11), info(12) - call var_to_geom(nvar,var) - call beta_slide(info(7),info(8),info(10),info(11),info(12), & - nfun,n) - call geom_to_var(nvar,var) - endif - - - if (info(3).eq.17) then - write(iout,*) 'calling beta_zip',info(7),info(8) - call var_to_geom(nvar,var) - call beta_zip(info(7),info(8),nfun,n) - call geom_to_var(nvar,var) - endif - - -!rc overlap test - - if (overlapsc) then - - call var_to_geom(nvar,var) - call chainbuild - call etotal(energia) - nfun=nfun+1 - if (energia(1).eq.1.0d20) then - info(3)=-info(3) - write (iout,'(a,1pe14.5)')'#OVERLAP evdw=1d20',energia(1) - call overlap_sc(fail) - if(.not.fail) then - call geom_to_var(nvar,var) - call etotal(energia) - nfun=nfun+1 - write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) - else - v(10)=1.0d20 - iv(1)=-1 - goto 201 - endif - endif - endif - - if (searchsc) then - call var_to_geom(nvar,var) - call sc_move(2,nres-1,1,10d0,nft_sc,etot) - call geom_to_var(nvar,var) -!d write(iout,*) 'sc_move',nft_sc,etot - endif - - if (check_var(var,info)) then - v(10)=1.0d21 - iv(1)=6 - goto 201 - endif - - -!rc - -! write (iout,*) 'MINIM_JLEE: Processor',me,' nvar',nvar -! write (iout,'(8f10.4)') (var(i),i=1,nvar) -! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar -! write (*,'(8f10.4)') (var(i),i=1,nvar) - - do i=1,nvar - garbage(i)=var(i) - enddo - - call deflt(2,iv,liv,lv,v) -! 12 means fresh start, dont call deflt - iv(1)=12 -! max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -! max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -! controls output - iv(19)=2 -! selects output unit -!d iv(21)=iout - iv(21)=0 -! 1 means to print out result - iv(22)=0 -!d iv(22)=1 -! 1 means to print out summary stats - iv(23)=0 -! 1 means to print initial x and d - iv(24)=0 - -! if(me.eq.3.and.n.eq.255) then -! print *,' CHUJ: stoi' -! iv(21)=6 -! iv(22)=1 -! iv(23)=1 -! iv(24)=1 -! endif - -! min val for v(radfac) default is 0.1 - v(24)=0.1D0 -! max val for v(radfac) default is 4.0 - v(25)=2.0D0 -! v(25)=4.0D0 -! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -! the sumsl default is 0.1 - v(26)=0.1D0 -! false conv if (act fnctn decrease) .lt. v(34) -! the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -! absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -! relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -! controls initial step size - v(35)=1.0D-1 -! large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -! minimize energy -! write (iout,*) 'Processor',me,' nvar',nvar -! write (iout,*) 'Variables BEFORE minimization:' -! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) - -! print *, 'MINIM_JLEE: ',me,' before SUMSL ' - - call func(nvar,var,nf,eee,idum,rdum,fdum) - nfun=nfun+1 - if(eee.ge.1.0d20) then -! print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' -! print *,' energy before SUMSL =',eee -! print *,' aborting local minimization' - iv(1)=-1 - v(10)=eee - go to 201 - endif - -!t time0s=MPI_WTIME() - call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) -!t write(iout,*) 'sumsl time=',MPI_WTIME()-time0s,iv(7),v(10) -! print *, 'MINIM_JLEE: ',me,' after SUMSL ' - -! find which conformation was returned from sumsl - nfun=nfun+iv(7) -! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, -! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) -! if (iv(1).ne.4 .or. nf.le.1) then -! write (*,*) 'Processor',me,' something bad in SUMSL',iv(1),nf -! write (*,*) 'Initial Variables' -! write (*,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) -! write (*,*) 'Variables' -! write (*,'(8f10.4)') (rad2deg*var(i),i=1,nvar) -! write (*,*) 'Vector d' -! write (*,'(8f10.4)') (d(i),i=1,nvar) -! write (iout,*) 'Processor',me,' something bad in SUMSL', -! & iv(1),nf -! write (iout,*) 'Initial Variables' -! write (iout,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) -! write (iout,*) 'Variables' -! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) -! write (iout,*) 'Vector d' -! write (iout,'(8f10.4)') (d(i),i=1,nvar) -! endif -! if (nf.lt.iv(6)-1) then -! recalculate intra- and interchain energies -! call func(nvar,var,nf,v(10),iv,v,fdum) -! else if (nf.eq.iv(6)-1) then -! regenerate conformation -! call var_to_geom(nvar,var) -! call chainbuild -! endif -! change origin and axes to standard ECEPP format -! call var_to_geom(nvar,var) -! write (iout,*) 'MINIM_JLEE after minim: Processor',me,' nvar',nvar -! write (iout,'(8f10.4)') (var(i),i=1,nvar) -! write (iout,*) 'Energy:',v(10) -! send back output -! print *, 'MINIM_JLEE: ',me,' minimized: ',n - 201 continue - indx(1)=n -! return code: 6-gradient 9-number of ftn evaluation, etc - indx(2)=iv(1) -! total # of ftn evaluations (for iwf=0, it includes all minimizations). - indx(3)=nfun - indx(4)=info(2) - indx(5)=info(3) - indx(6)=nss - indx(7)=info(5) - indx(8)=info(6) - indx(9)=info(9) - call mpi_send(indx,9,mpi_integer,king,idint,CG_COMM,& - ierr) -! send back energies -! al & cc -! calculate contact order -#ifdef CO_BIAS - call contact(.false.,ncont,icont_,co) - erg(1)=v(10)-1.0d2*co -#else - erg(1)=v(10) -#endif - j=1 - call mpi_send(erg,j,mpi_double_precision,king,idreal,& - CG_COMM,ierr) -#ifdef CO_BIAS - call mpi_send(co,j,mpi_double_precision,king,idreal,& - CG_COMM,ierr) -#endif -! send back values of variables - call mpi_send(var,nvar,mpi_double_precision,& - king,idreal,CG_COMM,ierr) -! print * , 'MINIM_JLEE: Processor',me,' send erg and var ' - - if(vdisulf.and.info(2).ne.-1.and.nss.ne.0) then -!d call intout -!d call chainbuild -!d call etotal(energia(0)) -!d etot=energia(0) -!d call enerprint(energia(0)) - call mpi_send(ihpb,nss,mpi_integer,& - king,idint,CG_COMM,ierr) - call mpi_send(jhpb,nss,mpi_integer,& - king,idint,CG_COMM,ierr) - endif - - go to 10 - 100 print *, ' error in receiving message from emperor', me - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 200 print *, ' error in sending message to emperor' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 300 print *, ' error in communicating with emperor' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 956 format (' initial energy could not be calculated',41x) - 957 format (80x) - 965 format (' convergence code ',i2,' # of function calls ',& - i4,' # of gradient calls ',i4,10x) - 975 format (' energy ',1p,e12.4,' scaled gradient ',e11.3,32x) - end subroutine minim_jlee -!----------------------------------------------------------------------------- -! newconf.f -!----------------------------------------------------------------------------- - subroutine make_var(n,idum,iter_csa) - - use MD_data - use energy_data - use compare_data - use control_data, only: vdisulf - use geometry_data - use geometry, only: dist - include 'mpif.h' - -! use random, only: iran_num,ran_number -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.HAIRPIN' -! include 'COMMON.VAR' -! include 'COMMON.DISTFIT' -! include 'COMMON.GEO' -! include 'COMMON.CONTROL' - logical :: nicht_getan,nicht_getan1,fail,lfound - integer :: nharp,iharp(4,nres/3),nconf_harp - integer :: iisucc(mxio) - logical :: ifused(mxio) - integer :: nhx_seed(nseed),ihx_seed(4,nres/3,nseed) !max_seed - integer :: nhx_use(nseed),ihx_use(0:4,nres/3,nseed) - integer :: nlx_seed(nseed),ilx_seed(2,nres/3,nseed),& - nlx_use(nseed),ilx_use(nres/3,nseed) -! real(kind=4) :: ran1,ran2 - - integer :: i,j,k,n,idum,iter_csa,iran,index,n7frag,n8frag,n14frag,& - n15frag,nbefrag,nlx_tot,iters,i1,i2,i3,ntot_gen,ngen,iih,& - ij,jr,iim,nhx_tot,idummy,iter,iif,iig,icheck,ishift,iang,& - n8c,ih_start,ih_end,n7c,index2,isize,nsucc,nacc,j1,nran,& - ierror,ierrcode - real(kind=8) :: d - - write (iout,*) 'make_var : nseed=',nseed,'ntry=',n - index=0 - -!----------------------------------------- - if (n7.gt.0.or.n8.gt.0.or.n9.gt.0.or.n14.gt.0.or.n15.gt.0 & - .or.n16.gt.0.or.n17.gt.0.or.n18.gt.0) & - call select_frag(n7frag,n8frag,n14frag,& - n15frag,nbefrag,iter_csa) - -!--------------------------------------------------- -! N18 - random perturbation of one phi(=gamma) angle in a loop -! - IF (n18.gt.0) THEN - nlx_tot=0 - do iters=1,nseed - i1=is(iters) - nlx_seed(iters)=0 - do i2=1,n14frag - if (lvar_frag(i2,1).eq.i1) then - nlx_seed(iters)=nlx_seed(iters)+5 - ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) - ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) - ilx_use(nlx_seed(iters),iters)=5 - endif - enddo - nlx_use(iters)=nlx_seed(iters) - nlx_tot=nlx_tot+nlx_seed(iters) - enddo - - if (nlx_tot .ge. n18*nseed) then - ntot_gen=n18*nseed - else - ntot_gen=(nlx_tot/nseed)*nseed - endif - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nlx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nlx_seed(iters)) - if (ilx_use(iih,iters).gt.0) then - nicht_getan=.false. - ilx_use(iih,iters)=ilx_use(iih,iters)-1 - nlx_use(iters)=nlx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=18 - parent(1,index)=iseed - parent(2,index)=0 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - jr=iran_num(ilx_seed(1,iih,iters),ilx_seed(2,iih,iters)) - d=ran_number(-pi,pi) - dihang_in(2,jr-2,1,index)=pinorm(dihang_in(2,jr-2,1,index)+d) - - - if (ngen.eq.ntot_gen) goto 145 - endif - enddo - enddo - 145 continue - - ENDIF - - -!----------------------------------------- -! N17 : zip a beta in a seed by forcing one additional p-p contact -! - IF (n17.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - nhx_use(iters)=0 - do i2=1,nbefrag - if (avar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_use(2,nhx_seed(iters),iters)=1 - if (avar_frag(i2,5)-avar_frag(i2,3).le.3.and. & - avar_frag(i2,2).gt.1.and.avar_frag(i2,4).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - else - if (avar_frag(i2,4).gt.avar_frag(i2,5)) then - if (avar_frag(i2,2).gt.1.and. & - avar_frag(i2,4).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - if (avar_frag(i2,3).lt.nres.and. & - avar_frag(i2,5).gt.1) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)-1 - ihx_use(0,nhx_seed(iters),iters)= & - ihx_use(0,nhx_seed(iters),iters)+1 - ihx_use(2,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - else - if (avar_frag(i2,2).gt.1.and. & - avar_frag(i2,4).gt.1) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)-1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - if (avar_frag(i2,3).lt.nres.and. & - avar_frag(i2,5).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)+1 - ihx_use(0,nhx_seed(iters),iters)= & - ihx_use(0,nhx_seed(iters),iters)+1 - ihx_use(2,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - endif - endif - endif - enddo - - nhx_tot=nhx_tot+nhx_use(iters) -!d write (iout,*) "debug N17",iters,nhx_seed(iters), -!d & nhx_use(iters),nhx_tot - enddo - - if (nhx_tot .ge. n17*nseed) then - ntot_gen=n17*nseed - else if (nhx_tot .ge. nseed) then - ntot_gen=(nhx_tot/nseed)*nseed - else - ntot_gen=nhx_tot - endif -!d write (iout,*) "debug N17==",ntot_gen,nhx_tot,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then -!d write (iout,*) "debug N17",nhx_use(iters),ngen,ntot_gen -!d write (iout,*) "debugN17^", -!d & (ihx_use(0,k,iters),k=1,nhx_use(iters)) - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) -!d write (iout,*) "debugN17^",iih - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,2) -!d write (iout,*) "debugN17=",iih,nhx_seed(iters) -!d write (iout,*) "debugN17-",iim,'##', -!d & (ihx_use(k,iih,iters),k=0,2) -!d call flush(iout) - do while (ihx_use(iim,iih,iters).eq.1) - iim=iran_num(1,2) -!d write (iout,*) "debugN17-",iim,'##', -!d & (ihx_use(k,iih,iters),k=0,2) -!d call flush(iout) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=17 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - if (iim.eq.1) then - idata(1,index)=ihx_seed(1,iih,iters) - idata(2,index)=ihx_seed(2,iih,iters) - else - idata(1,index)=ihx_seed(3,iih,iters) - idata(2,index)=ihx_seed(4,iih,iters) - endif - - if (ngen.eq.ntot_gen) goto 115 - endif - enddo - enddo - 115 continue - write (iout,*) "N17",n17," ngen/nseed",ngen/nseed,& - ngen,nseed - - - ENDIF -!----------------------------------------- -! N16 : slide non local beta in a seed by +/- 1 or +/- 2 -! - IF (n16.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - do i2=1,n7frag - if (bvar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_seed(1,nhx_seed(iters),iters)=bvar_frag(i2,3) - ihx_seed(2,nhx_seed(iters),iters)=bvar_frag(i2,4) - ihx_seed(3,nhx_seed(iters),iters)=bvar_frag(i2,5) - ihx_seed(4,nhx_seed(iters),iters)=bvar_frag(i2,6) - ihx_use(0,nhx_seed(iters),iters)=4 - do i3=1,4 - ihx_use(i3,nhx_seed(iters),iters)=0 - enddo - endif - enddo - nhx_use(iters)=4*nhx_seed(iters) - nhx_tot=nhx_tot+nhx_seed(iters) -!d write (iout,*) "debug N16",iters,nhx_seed(iters) - enddo - - if (4*nhx_tot .ge. n16*nseed) then - ntot_gen=n16*nseed - else if (4*nhx_tot .ge. nseed) then - ntot_gen=(4*nhx_tot/nseed)*nseed - else - ntot_gen=4*nhx_tot - endif - write (iout,*) "debug N16",ntot_gen,4*nhx_tot,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,4) - do while (ihx_use(iim,iih,iters).eq.1) -!d write (iout,*) iim, -!d & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) - iim=iran_num(1,4) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=16 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do i=1,4 - idata(i,index)=ihx_seed(i,iih,iters) - enddo - idata(5,index)=iim - - if (ngen.eq.ntot_gen) goto 116 - endif - enddo - enddo - 116 continue - write (iout,*) "N16",n16," ngen/nseed",ngen/nseed,& - ngen,nseed - ENDIF -!----------------------------------------- -! N15 : copy two 2nd structure elements from 1 or 2 conf. in bank to a seed -! - IF (n15.gt.0) THEN - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - do idummy=1,n15 - iter=0 - 84 continue - - iran=0 - iif=iran_num(1,n15frag) - do while( (ifused(iif) .or. svar_frag(iif,1).eq.iseed) .and. & - iran.le.mxio ) - iif=iran_num(1,n15frag) - iran=iran+1 - enddo - if(iran.ge.mxio) goto 811 - - iran=0 - iig=iran_num(1,n15frag) - do while( (ifused(iig) .or. svar_frag(iig,1).eq.iseed .or. & - .not.(svar_frag(iif,3).lt.svar_frag(iig,2).or. & - svar_frag(iig,3).lt.svar_frag(iif,2)) ) .and. & - iran.le.mxio ) - iig=iran_num(1,n15frag) - iran=iran+1 - enddo - if(iran.ge.mxio) goto 811 - - index=index+1 - movenx(index)=15 - parent(1,index)=iseed - parent(2,index)=svar_frag(iif,1) - parent(3,index)=svar_frag(iig,1) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - ifused(iif)=.true. - ifused(iig)=.true. - call newconf_copy(idum,dihang_in(1,1,1,index),& - svar_frag(iif,1),svar_frag(iif,2),svar_frag(iif,3)) - - do j=svar_frag(iig,2),svar_frag(iig,3) - do i=1,4 - dihang_in(i,j,1,index)=bvar(i,j,1,svar_frag(iig,1)) - enddo - enddo - - - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) then - index=index-1 - ifused(iif)=.false. - goto 84 - endif - endif - - 811 continue - enddo - enddo - ENDIF - -!----------------------------------------- -! N14 local_move (Maurizio) for loops in a seed -! - IF (n14.gt.0) THEN - nlx_tot=0 - do iters=1,nseed - i1=is(iters) - nlx_seed(iters)=0 - do i2=1,n14frag - if (lvar_frag(i2,1).eq.i1) then - nlx_seed(iters)=nlx_seed(iters)+3 - ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) - ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) - ilx_use(nlx_seed(iters),iters)=3 - endif - enddo - nlx_use(iters)=nlx_seed(iters) - nlx_tot=nlx_tot+nlx_seed(iters) -!d write (iout,*) "debug N14",iters,nlx_seed(iters) - enddo - - if (nlx_tot .ge. n14*nseed) then - ntot_gen=n14*nseed - else - ntot_gen=(nlx_tot/nseed)*nseed - endif -!d write (iout,*) "debug N14",ntot_gen,n14frag,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nlx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nlx_seed(iters)) - if (ilx_use(iih,iters).gt.0) then - nicht_getan=.false. - ilx_use(iih,iters)=ilx_use(iih,iters)-1 - nlx_use(iters)=nlx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=14 - parent(1,index)=iseed - parent(2,index)=0 - - idata(1,index)=ilx_seed(1,iih,iters) - idata(2,index)=ilx_seed(2,iih,iters) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - if (ngen.eq.ntot_gen) goto 131 - endif - enddo - enddo - 131 continue -!d write (iout,*) "N14",n14," ngen/nseed",ngen/nseed, -!d & ngen,nseed - - ENDIF -!----------------------------------------- -! N9 : shift a helix in a seed -! - IF (n9.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - do i2=1,n8frag - if (hvar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_seed(1,nhx_seed(iters),iters)=hvar_frag(i2,2) - ihx_seed(2,nhx_seed(iters),iters)=hvar_frag(i2,3) - ihx_use(0,nhx_seed(iters),iters)=4 - do i3=1,4 - ihx_use(i3,nhx_seed(iters),iters)=0 - enddo - endif - enddo - nhx_use(iters)=4*nhx_seed(iters) - nhx_tot=nhx_tot+nhx_seed(iters) -!d write (iout,*) "debug N9",iters,nhx_seed(iters) - enddo - - if (4*nhx_tot .ge. n9*nseed) then - ntot_gen=n9*nseed - else - ntot_gen=(4*nhx_tot/nseed)*nseed - endif -!d write (iout,*) "debug N9",ntot_gen,n8frag,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,4) - do while (ihx_use(iim,iih,iters).eq.1) -!d write (iout,*) iim, -!d & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) - iim=iran_num(1,4) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=9 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - jstart=max(nnt,ihx_seed(1,iih,iters)+1) - jend=min(nct,ihx_seed(2,iih,iters)) -!d write (iout,*) "debug N9",iters,iih,jstart,jend - if (iim.eq.1) then - ishift=-2 - else if (iim.eq.2) then - ishift=-1 - else if (iim.eq.3) then - ishift=1 - else if (iim.eq.4) then - ishift=2 - else - write (iout,*) 'CHUJ NASTAPIL: iim=',iim -#ifdef MPI !el - call mpi_abort(mpi_comm_world,ierror,ierrcode) -#endif - endif - do j=jstart,jend - if (itype(j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (j+ishift.ge.nnt.and.j+ishift.le.nct) & - dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) - enddo - enddo - if (ishift.gt.0) then - do j=0,ishift-1 - if (itype(jend+j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (jend+j.ge.nnt.and.jend+j.le.nct) & - dihang_in(i,jstart+j,1,index)=bvar(i,jend+j,1,iseed) - enddo - enddo - else - do j=0,-ishift-1 - if (itype(jstart+j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (jend+j.ge.nnt.and.jend+j.le.nct) & - dihang_in(i,jend+j,1,index)=bvar(i,jstart+j,1,iseed) - enddo - enddo - endif - if (ngen.eq.ntot_gen) goto 133 - endif - enddo - enddo - 133 continue -!d write (iout,*) "N9",n9," ngen/nseed",ngen/nseed, -!d & ngen,nseed - - ENDIF -!----------------------------------------- -! N8 : copy a helix from bank to seed -! - if (n8.gt.0) then - if (n8frag.lt.n8) then - write (iout,*) "N8: only ",n8frag,'helices' - n8c=n8frag - else - n8c=n8 - endif - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - - do idummy=1,n8c - iter=0 - 94 continue - iran=0 - iif=iran_num(1,n8frag) - do while( (ifused(iif) .or. hvar_frag(iif,1).eq.iseed) .and. & - iran.le.mxio ) - iif=iran_num(1,n8frag) - iran=iran+1 - enddo - - if(iran.ge.mxio) goto 911 - - index=index+1 - movenx(index)=8 - parent(1,index)=iseed - parent(2,index)=hvar_frag(iif,1) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - ifused(iif)=.true. - if (hvar_frag(iif,3)-hvar_frag(iif,2).le.6) then - call newconf_copy(idum,dihang_in(1,1,1,index),& - hvar_frag(iif,1),hvar_frag(iif,2),hvar_frag(iif,3)) - else - ih_start=iran_num(hvar_frag(iif,2),hvar_frag(iif,3)-6) - ih_end=iran_num(ih_start,hvar_frag(iif,3)) - call newconf_copy(idum,dihang_in(1,1,1,index),& - hvar_frag(iif,1),ih_start,ih_end) - endif - iter=iter+1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) then - index=index-1 - ifused(iif)=.false. - goto 94 - endif - endif - - - 911 continue - - enddo - enddo - - endif - -!----------------------------------------- -! N7 : copy nonlocal beta fragment from bank to seed -! - if (n7.gt.0) then - if (n7frag.lt.n7) then - write (iout,*) "N7: only ",n7frag,'nonlocal fragments' - n7c=n7frag - else - n7c=n7 - endif - - do i=1,nres - do j=1,mxio2 - iff_in(i,j)=0 - enddo - enddo - index2=0 - do i=1,mxio - isend2(i)=0 - enddo - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - do idummy=1,n7c - iran=0 - iif=iran_num(1,n7frag) - do while( (ifused(iif) .or. bvar_frag(iif,1).eq.iseed) .and. & - iran.le.mxio ) - iif=iran_num(1,n7frag) - iran=iran+1 - enddo - -!d write (*,'(3i5,l,4i5)'),iters,idummy,iif,ifused(iif), -!d & bvar_frag(iif,1),iseed,iran,index2 - - if(iran.ge.mxio) goto 999 - if(index2.ge.mxio2) goto 999 - - index=index+1 - movenx(index)=7 - parent(1,index)=iseed - parent(2,index)=bvar_frag(iif,1) - index2=index2+1 - isend2(index)=index2 - ifused(iif)=.true. - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in2(i,j,k,index2)=bvar(i,j,k,bvar_frag(iif,1)) - enddo - enddo - enddo - - if (bvar_frag(iif,2).eq.4) then - do i=bvar_frag(iif,3),bvar_frag(iif,4) - iff_in(i,index2)=1 - enddo - if (bvar_frag(iif,5).lt.bvar_frag(iif,6)) then -!d print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), -!d & bvar_frag(iif,5),bvar_frag(iif,6) - do i=bvar_frag(iif,5),bvar_frag(iif,6) - iff_in(i,index2)=1 - enddo - else -!d print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), -!d & bvar_frag(iif,6),bvar_frag(iif,5) - do i=bvar_frag(iif,6),bvar_frag(iif,5) - iff_in(i,index2)=1 - enddo - endif - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - 999 continue - - enddo - enddo - - endif -!----------------------------------------------- -! N6 : copy random continues fragment from bank to seed -! - do iters=1,nseed - iseed=is(iters) - do idummy=1,n6 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 104 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 104 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 104 - endif - enddo - enddo -!----------------------------------------- - if (n3.gt.0.or.n4.gt.0) call gen_hairpin - nconf_harp=0 - do iters=1,nseed - if (nharp_seed(iters).gt.0) nconf_harp=nconf_harp+1 - enddo -!----------------------------------------- -! N3 : copy hairpin from bank to seed -! - do iters=1,nseed - iseed=is(iters) - nsucc=0 - nacc=0 - do idummy=1,n3 - index=index+1 - iter=0 - 124 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 124 - do k=1,nsucc - if (i1.eq.iisucc(k).and.nsucc.lt.nconf_harp-1) goto 124 - enddo - nsucc=nsucc+1 - iisucc(nsucc)=i1 - iter=iter+1 - call newconf_residue_hairpin(idum,dihang_in(1,1,1,index),& - i1,fail) - if (fail) then - if (icycle.le.0 .and. nsucc.eq.nconf .or. & - icycle.gt.0 .and. nsucc.eq.nbank) then - index=index-1 - goto 125 - else - goto 124 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 124 - endif - movenx(index)=3 - parent(1,index)=iseed - parent(2,index)=i1 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - nacc=nacc+1 - enddo -! if not enough hairpins, supplement with windows - 125 continue -!dd if (n3.ne.0) write (iout,*) "N3",n3," nsucc",nsucc," nacc",nacc - do idummy=nacc+1,n3 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - parent(1,index)=iseed - parent(2,index)=i1 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 114 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 114 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 114 - endif - enddo - enddo -!----------------------------------------- -! N4 : shift a turn in hairpin in seed -! - IF (N4.GT.0) THEN - if (4*nharp_tot .ge. n4*nseed) then - ntot_gen=n4*nseed - else - ntot_gen=(4*nharp_tot/nseed)*nseed - endif - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) -! write (iout,*) 'iters',iters,' iseed',iseed,' nharp_seed', -! & nharp_seed(iters),' nharp_use',nharp_use(iters), -! & ' ntot_gen',ntot_gen -! write (iout,*) 'iharp_use(0)', -! & (iharp_use(0,k,iters),k=1,nharp_seed(iters)) - if (nharp_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nharp_seed(iters)) -! write (iout,*) 'iih',iih,' iharp_use', -! & (iharp_use(k,iih,iters),k=1,4) - if (iharp_use(0,iih,iters).gt.0) then - nicht_getan1=.true. - do while (nicht_getan1) - iim=iran_num(1,4) - nicht_getan1=iharp_use(iim,iih,iters).eq.1 - enddo - nicht_getan=.false. - iharp_use(iim,iih,iters)=1 - iharp_use(0,iih,iters)=iharp_use(0,iih,iters)-1 - nharp_use(iters)=nharp_use(iters)-1 -!dd write (iout,'(a16,i3,a5,i2,a10,2i4)') -!dd & 'N4 selected hairpin',iih,' move',iim,' iharp_seed', -!dd & iharp_seed(1,iih,iters),iharp_seed(2,iih,iters) - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=4 - parent(1,index)=iseed - parent(2,index)=0 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - jstart=iharp_seed(1,iih,iters)+1 - jend=iharp_seed(2,iih,iters) - if (iim.eq.1) then - ishift=-2 - else if (iim.eq.2) then - ishift=-1 - else if (iim.eq.3) then - ishift=1 - else if (iim.eq.4) then - ishift=2 - else - write (iout,*) 'CHUJ NASTAPIL: iim=',iim -#ifdef MPI !el - call mpi_abort(mpi_comm_world,ierror,ierrcode) -#endif !el - endif -! write (iout,*) 'jstart',jstart,' jend',jend,' ishift',ishift -! write (iout,*) 'Before turn shift' -! do j=2,nres-1 -! theta(j+1)=dihang_in(1,j,1,index) -! phi(j+2)=dihang_in(2,j,1,index) -! alph(j)=dihang_in(3,j,1,index) -! omeg(j)=dihang_in(4,j,1,index) -! enddo -! call intout - do j=jstart,jend - if (itype(j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (j+ishift.ge.nnt.and.j+ishift.le.nct) & - dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) - enddo - enddo -! write (iout,*) 'After turn shift' -! do j=2,nres-1 -! theta(j+1)=dihang_in(1,j,1,index) -! phi(j+2)=dihang_in(2,j,1,index) -! alph(j)=dihang_in(3,j,1,index) -! omeg(j)=dihang_in(4,j,1,index) -! enddo -! call intout - if (ngen.eq.ntot_gen) goto 135 - endif - enddo - enddo -! if not enough hairpins, supplement with windows -! write (iout,*) 'end of enddo' - 135 continue -!dd write (iout,*) "N4",n4," ngen/nseed",ngen/nseed, -!dd & ngen,nseed - do iters=1,nseed - iseed=is(iters) - do idummy=ngen/nseed+1,n4 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - iter=0 - 134 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 134 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 134 - endif - enddo - enddo - ENDIF -!----------------------------------------- -! N5 : copy one residue from bank to seed (normally switched off - use N1) -! - do iters=1,nseed - iseed=is(iters) - isize=1 - do i=1,n5 - index=index+1 - movenx(index)=5 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - iter=0 - 105 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 105 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 105 - endif - enddo - enddo -!----------------------------------------- -! N2 : copy backbone of one residue from bank or first bank to seed -! (normally switched off - use N1) -! - do iters=1,nseed - iseed=is(iters) - do i=n2,1,-1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - iseed=ran1(idum)*nconf+1 - iseed=nbank-nconf+iseed - endif - index=index+1 - movenx(index)=2 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 102 i1= ran1(idum)*nbank+1 - if(i1.eq.iseed) goto 102 - iter=iter+1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - nran=mod(i-1,nran0)+3 - call newconf1arr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=-iseed - parent(2,index)=-i1 - else if(icycle.le.0.and.iters.le.iuse) then - nran=mod(i-1,nran0)+1 - call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - nran=mod(i-1,nran1)+1 - if(ran1(idum).lt.0.5) then - call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - call newconf1abb(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=i1 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 102 - endif - enddo - enddo -!----------------------------------------- -! N1 : copy backbone or sidechain of one residue from bank or -! first bank to seed -! - do iters=1,nseed - iseed=is(iters) - do i=n1,1,-1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - iseed=ran1(idum)*nconf+1 - iseed=nbank-nconf+iseed - endif - index=index+1 - movenx(index)=1 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 101 i1= ran1(idum)*nbank+1 - - if(i1.eq.iseed) goto 101 - iter=iter+1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - nran=mod(i-1,nran0)+3 - call newconf1rr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=-iseed - parent(2,index)=-i1 - else if(icycle.le.0.and.iters.le.iuse) then - nran=mod(i-1,nran0)+1 - call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - nran=mod(i-1,nran1)+1 - if(ran1(idum).lt.0.5) then - call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - call newconf1bb(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=i1 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 101 - endif - enddo - enddo -!----------------------------------------- -! N0 just all seeds -! - IF (n0.gt.0) THEN - do iters=1,nseed - iseed=is(iters) - index=index+1 - movenx(index)=0 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - enddo - ENDIF -!----------------------------------------- - if (vdisulf) then - do iters=1,nseed - iseed=is(iters) - - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,iseed) - phi(j+2)=bvar(2,j,k,iseed) - alph(j)=bvar(3,j,k,iseed) - omeg(j)=bvar(4,j,k,iseed) - enddo - enddo - call chainbuild - -!d write(iout,*) 'makevar DYNSS',iseed,'#',bvar_ns(iseed), -!d & (bvar_s(k,iseed),k=1,bvar_ns(iseed)), -!d & bvar_nss(iseed), -!d & (bvar_ss(1,k,iseed)-nres,'-', -!d & bvar_ss(2,k,iseed)-nres,k=1,bvar_nss(iseed)) - - do i1=1,bvar_ns(iseed) -! -! N10 fussion of free halfcysteines in seed -! first select CYS with distance < 7A -! - do j1=i1+1,bvar_ns(iseed) - if (dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres) & - .lt.7.0.and. & - iabs(bvar_s(i1,iseed)-bvar_s(j1,iseed)).gt.3) then - - index=index+1 - movenx(index)=10 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - ij=bvar_nss(iseed)+1 - nss_in(index)=ij - iss_in(ij,index)=bvar_s(i1,iseed)+nres - jss_in(ij,index)=bvar_s(j1,iseed)+nres - -!d write(iout,*) 'makevar NSS0',index, -!d & dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres), -!d & nss_in(index),iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - enddo -! -! N11 type I transdisulfidation -! - do j1=1,bvar_nss(iseed) - if (dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)) & - .lt.7.0.and. & - iabs(bvar_s(i1,iseed)-(bvar_ss(1,j1,iseed)-nres)) & - .gt.3) then - - index=index+1 - movenx(index)=11 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(j1,index)=bvar_s(i1,iseed)+nres - jss_in(j1,index)=bvar_ss(1,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(1,j1,iseed) - jss_in(j1,index)=bvar_s(i1,iseed)+nres - endif - -!d write(iout,*) 'makevar NSS1 #1',index, -!d & bvar_s(i1,iseed),bvar_ss(1,j1,iseed)-nres, -!d & dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)), -!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -!d & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - endif - if (dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)) & - .lt.7.0.and. & - iabs(bvar_s(i1,iseed)-(bvar_ss(2,j1,iseed)-nres)) & - .gt.3) then - - index=index+1 - movenx(index)=11 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(j1,index)=bvar_s(i1,iseed)+nres - jss_in(j1,index)=bvar_ss(2,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(2,j1,iseed) - jss_in(j1,index)=bvar_s(i1,iseed)+nres - endif - - -!d write(iout,*) 'makevar NSS1 #2',index, -!d & bvar_s(i1,iseed),bvar_ss(2,j1,iseed)-nres, -!d & dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)), -!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -!d & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - enddo - enddo - -! -! N12 type II transdisulfidation -! - do i1=1,bvar_nss(iseed) - do j1=i1+1,bvar_nss(iseed) - if (dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)) & - .lt.7.0.and. & - dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)) & - .lt.7.0.and. & - iabs(bvar_ss(1,i1,iseed)-bvar_ss(1,j1,iseed)) & - .gt.3.and. & - iabs(bvar_ss(2,i1,iseed)-bvar_ss(2,j1,iseed)) & - .gt.3) then - index=index+1 - movenx(index)=12 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.i1 .and. ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(i1,index)=bvar_ss(1,i1,iseed) - jss_in(i1,index)=bvar_ss(1,j1,iseed) - if (iss_in(i1,index).gt.jss_in(i1,index)) then - iss_in(i1,index)=bvar_ss(1,j1,iseed) - jss_in(i1,index)=bvar_ss(1,i1,iseed) - endif - iss_in(j1,index)=bvar_ss(2,i1,iseed) - jss_in(j1,index)=bvar_ss(2,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(2,j1,iseed) - jss_in(j1,index)=bvar_ss(2,i1,iseed) - endif - - -!d write(iout,*) 'makevar NSS2 #1',index, -!d & bvar_ss(1,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, -!d & dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)), -!d & bvar_ss(2,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, -!d & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)), -!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -!d & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - if (dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)) & - .lt.7.0.and. & - dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)) & - .lt.7.0.and. & - iabs(bvar_ss(1,i1,iseed)-bvar_ss(2,j1,iseed)) & - .gt.3.and. & - iabs(bvar_ss(2,i1,iseed)-bvar_ss(1,j1,iseed)) & - .gt.3) then - index=index+1 - movenx(index)=12 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.i1 .and. ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(i1,index)=bvar_ss(1,i1,iseed) - jss_in(i1,index)=bvar_ss(2,j1,iseed) - if (iss_in(i1,index).gt.jss_in(i1,index)) then - iss_in(i1,index)=bvar_ss(2,j1,iseed) - jss_in(i1,index)=bvar_ss(1,i1,iseed) - endif - iss_in(j1,index)=bvar_ss(2,i1,iseed) - jss_in(j1,index)=bvar_ss(1,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(1,j1,iseed) - jss_in(j1,index)=bvar_ss(2,i1,iseed) - endif - - -!d write(iout,*) 'makevar NSS2 #2',index, -!d & bvar_ss(1,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, -!d & dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)), -!d & bvar_ss(2,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, -!d & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)), -!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -!d & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - - enddo - enddo -! -! N13 removal of disulfide bond -! - if (bvar_nss(iseed).gt.0) then - i1=bvar_nss(iseed)*ran1(idum)+1 - - index=index+1 - movenx(index)=13 - parent(1,index)=iseed - parent(2,index)=0 - ij=0 - do j1=1,bvar_nss(iseed) - if (j1.ne.i1) then - ij=ij+1 - iss_in(ij,index)=bvar_ss(1,j1,iseed) - jss_in(ij,index)=bvar_ss(2,j1,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed)-1 - -!d write(iout,*) 'NSS3',index,i1, -!d & bvar_ss(1,i1,iseed)-nres,'=',bvar_ss(2,i1,iseed)-nres,'#', -!d & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -!d & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - enddo - endif -!----------------------------------------- - - - - if(index.ne.n) write(iout,*)'make_var : ntry=',index - - n=index -!d do ii=1,n -!d write (istat,*) "======== ii=",ii," the dihang array" -!d do i=1,nres -!d write (istat,'(i5,4f15.5)') i,(dihang_in(k,i,1,ii)*rad2deg,k=1,4) -!d enddo -!d enddo - return - end subroutine make_var -!----------------------------------------------------------------------------- - subroutine check_old(icheck,n) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - integer :: icheck,n,i1,i2,m,j,i - real(kind=8) :: ctdif,ctdiff,diff,dif - - data ctdif /10./ - data ctdiff /60./ - - i1=n - do i2=1,n-1 - diff=0.d0 - do m=1,numch - do j=2,nres-1 - do i=1,4 - dif=rad2deg*dabs(dihang_in(i,j,m,i1)-dihang_in(i,j,m,i2)) - if(dif.gt.180.0) dif=360.0-dif - if(dif.gt.ctdif) goto 100 - diff=diff+dif - if(diff.gt.ctdiff) goto 100 - enddo - enddo - enddo - icheck=1 - return - 100 continue - enddo - - icheck=0 - - return - end subroutine check_old -!----------------------------------------------------------------------------- - subroutine newconf1rr(idum,vvar,nran,i1) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind - real(kind=8) :: ctdif,dif - - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=rvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end subroutine newconf1rr -!----------------------------------------------------------------------------- - subroutine newconf1br(idum,vvar,nran,i1) - - use energy_data, only: ndih_nconstr,idih_nconstr - use control_data, only: i2ndstr -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,nran,i1,iran,index,number,iter,juhc,ind - real(kind=8) :: ctdif,dif,rtmp - - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - i=0 - do j=1,ndih_nconstr - if(igroup(2,1,iran).eq.idih_nconstr(j))i=j - enddo - if(i.eq.0) then - juhc=0 -4321 juhc=juhc+1 - iran= ran1(idum)*number+1 - i=0 - do j=1,ndih_nconstr - if(igroup(2,1,iran).eq.idih_nconstr(j))i=j - enddo - if(i.eq.0.or.juhc.lt.1000)goto 4321 - if(juhc.eq.1000) then - print *, 'move 6 : failed to find unconstrained group' - write(iout,*) 'move 6 : failed to find unconstrained group' - endif - endif - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end subroutine newconf1br -!----------------------------------------------------------------------------- - subroutine newconf1bb(idum,vvar,nran,i1) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind - real(kind=8) :: ctdif,dif - - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end subroutine newconf1bb -!----------------------------------------------------------------------------- - subroutine newconf1arr(idum,vvar,nran,i1) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind - real(kind=8) :: ctdif,dif - - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=rvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end subroutine newconf1arr -!----------------------------------------------------------------------------- - subroutine newconf1abr(idum,vvar,nran,i1) - - use energy_data, only: ndih_nconstr,idih_nconstr - use control_data, only: i2ndstr -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind - real(kind=8) :: ctdif,dif,rtmp - - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end subroutine newconf1abr -!----------------------------------------------------------------------------- - subroutine newconf1abb(idum,vvar,nran,i1) - - use energy_data, only: ndih_nconstr,idih_nconstr - use control_data, only: i2ndstr -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,nran,i1,iran,index,number,iter,ind - real(kind=8) :: ctdif,dif,rtmp - - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end subroutine newconf1abb -!----------------------------------------------------------------------------- - subroutine newconf_residue(idum,vvar,i1,isize) - - use energy_data, only: ndih_nconstr,idih_nconstr - use control_data, only: i2ndstr - use MPI_data - include 'mpif.h' -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,i1,isize,iran,number,iter,ind,iend,istart,& - ierror,ierrcode - real(kind=8) :: ctdif,dif,rtmp - - ctdif=10. - - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - k=1 - number=nres+isize-2 - iter=1 - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - istart=iran-isize+1 - iend=iran - if(istart.lt.2) istart=2 - if(iend.gt.nres-1) iend=nres-1 - - if(iter.eq.1) goto 11 - do ind=1,iter-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do j=istart,iend - do i=1,4 - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - enddo - iold(iter)=iran - iter=iter+1 - if(iter.gt.number) goto 20 - goto 10 - - 20 continue - do j=istart,iend - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - enddo - - return - end subroutine newconf_residue -!----------------------------------------------------------------------------- - subroutine newconf_copy(idum,vvar,i1,istart,iend) - - use MPI_data - include 'mpif.h' -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: i,j,k,idum,i1,istart,iend,ierror,ierrcode - real(kind=8) :: ctdif,dif - - ctdif=10. - - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - do j=istart,iend - do i=1,4 - vvar(i,j,1)=bvar(i,j,1,i1) - enddo - enddo - - return - end subroutine newconf_copy -!----------------------------------------------------------------------------- - subroutine newconf_residue_hairpin(idum,vvar,i1,fail) - - use geometry_data -! use random, only: iran_num - use MPI_data - use compare, only:hairpin - - include 'mpif.h' -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! real(kind=4) :: ran1,ran2 - real(kind=8),dimension(mxang,nres,mxch) :: vvar !(mxang,maxres,mxch) - integer,dimension(ntotal) :: iold - integer :: nharp,iharp(4,nres/3),icipa(nres/3) - logical :: fail,not_done - integer :: idum,i,j,k,i1,iend,istart,iii,n_used,icount,iih,& - ierror,ierrcode - real(kind=8) :: ctdif,dif - - ctdif=10. - - fail=.false. - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo -! call intout - call chainbuild - call hairpin(.false.,nharp,iharp) - - if (nharp.eq.0) then - fail=.true. - return - endif - - n_used=0 - - DO III=1,NHARP - - not_done = .true. - icount=0 - do while (not_done) - icount=icount+1 - iih=iran_num(1,nharp) - do k=1,n_used - if (iih.eq.icipa(k)) then - iih=0 - goto 22 - endif - enddo - not_done=.false. - n_used=n_used+1 - icipa(n_used)=iih - 22 continue - not_done = not_done .and. icount.le.nharp - enddo - - if (iih.eq.0) then - write (iout,*) "CHUJ NASTAPIL W NEWCONF_RESIDUE_HAIRPIN!!!!" - fail=.true. - return - endif - - istart=iharp(1,iih)+1 - iend=iharp(2,iih) - -!dd write (iout,*) "newconf_residue_hairpin: iih",iih, -!dd & " istart",istart," iend",iend - - do k=1,numch - do j=istart,iend - do i=1,4 - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - enddo - enddo - goto 10 - 20 continue - do k=1,numch - do j=istart,iend - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - enddo - enddo -! do j=1,numch -! do l=2,nres-1 -! write (iout,'(4f8.3)') (rad2deg*vvar(i,l,j),i=1,4) -! enddo -! enddo - return - 10 continue - ENDDO - - fail=.true. - - return - end subroutine newconf_residue_hairpin -!----------------------------------------------------------------------------- - subroutine gen_hairpin - - use geometry_data - use MD_data - use compare, only:hairpin -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.HAIRPIN' - integer :: i1,j,k,iters - -! write (iout,*) 'Entering GEN_HAIRPIN' - do iters=1,nseed - i1=is(iters) - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo - call chainbuild - call hairpin(.false.,nharp_seed(iters),iharp_seed(1,1,iters)) - enddo - - nharp_tot=0 - do iters=1,nseed - nharp_tot=nharp_tot+nharp_seed(iters) - nharp_use(iters)=4*nharp_seed(iters) - do j=1,nharp_seed(iters) - iharp_use(0,j,iters)=4 - do k=1,4 - iharp_use(k,j,iters)=0 - enddo - enddo - enddo - - write (iout,*) 'GEN_HAIRPIN: nharp_tot',nharp_tot -!dd do i=1,nseed -!dd write (iout,*) 'seed',i -!dd write (iout,*) 'nharp_seed',nharp_seed(i), -!dd & ' nharp_use',nharp_use(i) -!d write (iout,*) 'iharp_seed, iharp_use' -!d do j=1,nharp_seed(i) -!d write (iout,'(7i3)') iharp_seed(1,j,i),iharp_seed(2,j,i), -!d & (iharp_use(k,j,i),k=0,4) -!d enddo -!dd enddo - return - end subroutine gen_hairpin -!----------------------------------------------------------------------------- - subroutine select_frag(nn,nh,nl,ns,nb,i_csa) - - use geometry_data - use MD_data - use compare_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.HAIRPIN' -! include 'COMMON.DISTFIT' - character(len=50) :: linia - integer :: isec(nres) - integer :: i,j,i1,k,nn,nh,nl,ns,nb,i_csa,nl1,ns1 - - nn=0 - nh=0 - nl=0 - ns=0 - nb=0 -!d write (iout,*) 'Entering select_frag' - do i1=1,nbank - do i=1,nres - isec(i)=0 - enddo - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo - call chainbuild -!d write (iout,*) ' -- ',i1,' -- ' - call secondary2(.false.) -! -! bvar_frag nn==pair of nonlocal strands in beta sheet (loop>4) -! strands > 4 residues; used by N7 and N16 -! - do j=1,nbfrag -! -!test 09/12/02 bfrag(2,j)-bfrag(1,j).gt.3 -! - do i=bfrag(1,j),bfrag(2,j) - isec(i)=1 - enddo - do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) - isec(i)=1 - enddo - - if ( (bfrag(3,j).lt.bfrag(4,j) .or. & - bfrag(4,j)-bfrag(2,j).gt.4) .and. & - bfrag(2,j)-bfrag(1,j).gt.4 ) then - nn=nn+1 - - - if (bfrag(3,j).lt.bfrag(4,j)) then - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') & - "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& - ",",bfrag(3,j)-1,"-",bfrag(4,j)-1 - else - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') & - "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& - ",",bfrag(4,j)-1,"-",bfrag(3,j)-1 - - endif -!d call write_pdb(i_csa*1000+nn+nh,linia,0d0) - - bvar_frag(nn,1)=i1 - bvar_frag(nn,2)=4 - do i=1,4 - bvar_frag(nn,i+2)=bfrag(i,j) - enddo - endif - enddo - -! -! hvar_frag nh==helices; used by N8 and N9 -! - do j=1,nhfrag - - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - - if ( hfrag(2,j)-hfrag(1,j).gt.4 ) then - nh=nh+1 - -!d write(linia,'(a6,i3,a1,i3)') -!d & "select",hfrag(1,j)-1,"-",hfrag(2,j)-1 -!d call write_pdb(i_csa*1000+nn+nh,linia,0d0) - - hvar_frag(nh,1)=i1 - hvar_frag(nh,2)=hfrag(1,j) - hvar_frag(nh,3)=hfrag(2,j) - endif - enddo - - -!v write(iout,'(i4,1pe12.4,1x,1000i1)') -!v & i1,bene(i1),(isec(i),i=1,nres) -!v write(linia,'(i4,1x,1000i1)') -!v & i1,(isec(i),i=1,nres) -!v call write_pdb(i_csa*1000+i1,linia,bene(i1)) -! -! lvar_frag nl==loops; used by N14 -! - i=1 - nl1=nl - do while (i.lt.nres) - if (isec(i).eq.0) then - nl=nl+1 - lvar_frag(nl,1)=i1 - lvar_frag(nl,2)=i - i=i+1 - do while (isec(i).eq.0.and.i.le.nres) - i=i+1 - enddo - lvar_frag(nl,3)=i-1 - if (lvar_frag(nl,3)-lvar_frag(nl,2).lt.1) nl=nl-1 - endif - i=i+1 - enddo -!d write(iout,'(4i5)') (i,(lvar_frag(i,ii),ii=1,3),i=nl1+1,nl) - -! -! svar_frag ns==an secondary structure element; used by N15 -! - i=1 - ns1=ns - do while (i.lt.nres) - if (isec(i).gt.0) then - ns=ns+1 - svar_frag(ns,1)=i1 - svar_frag(ns,2)=i - i=i+1 - do while (isec(i).gt.0.and.isec(i-1).eq.isec(i) & - .and.i.le.nres) - i=i+1 - enddo - svar_frag(ns,3)=i-1 - if (svar_frag(ns,3)-svar_frag(ns,2).lt.1) ns=ns-1 - endif - if (isec(i).eq.0) i=i+1 - enddo -!d write(iout,'(4i5)') (i,(svar_frag(i,ii),ii=1,3),i=ns1+1,ns) - -! -! avar_frag nb==any pair of beta strands; used by N17 -! - do j=1,nbfrag - nb=nb+1 - avar_frag(nb,1)=i1 - do i=1,4 - avar_frag(nb,i+1)=bfrag(i,j) - enddo - enddo - - enddo - - return - end subroutine select_frag -!----------------------------------------------------------------------------- -! together.F -!----------------------------------------------------------------------------- - subroutine together - -! feeds tasks for parallel processing - use MPI_data - use geometry_data - use control_data, only: vdisulf - use energy_data - use io, only:from_int,write_csa_pdb -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! real(kind=4) :: ran1,ran2 -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.TIME1' -! include 'COMMON.SETUP' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.CONTROL' -! include 'COMMON.SBRIDGE' - real(kind=4) :: tcpu - real(kind=8) :: time_start,time_start_c,time0f,time0i - logical :: ovrtim,sync_iter,timeout,flag,timeout1 - integer,dimension(mpi_status_size) :: muster - real(kind=8),dimension(0:100) :: t100 - integer,dimension(mxio) :: indx - real(kind=8),dimension(6*nres) :: xout !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout - integer,dimension(9) :: ind - real(kind=8),dimension(2) :: cout - real(kind=8),parameter :: rad=1.745329252d-2 - - integer :: i,m,j,jlee,nft,idum,nrmsdb,nrmsdb1,ierr,ierror,ierrcode,& - ntrial,ntry,idum2,imax,idumm,nconfr,iconf,mm,k,im,nst,ifar,& - iter,irecv,isent,iw_pdb,nft0i,nft00_c,nft00,ifrom,ij,& - ireq,ireq2 - real(kind=8) :: adif,p_cut,cutdifr,rmsdbc1c,time1i,ctdif1,xctdif,& - time2i,tstart,tend1 -!ccccccccccccccccccccccccccccccccccccccccccccccc - sync_iter=.true. !el - nft=0 !el - time_start=0.0d0 - IF (ME.EQ.KING) THEN - - time0f=MPI_WTIME() - ilastnstep=1 - sync_iter=.false. - numch=1 - nrmsdb=0 - nrmsdb1=0 - rmsdbc1c=rmsdbc1 - nstep=0 - call csa_read - call make_array - - if(iref.ne.0) call from_int(1,0,idum) - -! To minimize input conformation (bank conformation) -! Output to $mol.reminimized - if (irestart.lt.0) then - call read_bank(0,nft,cutdifr) - if (irestart.lt.-10) then - p_cut=nres*4.d0 - call prune_bank(p_cut) - return - endif - call reminimize(jlee) - return - endif - - if (irestart.eq.0) then - call initial_write - nbank=nconf - ntbank=nconf - if (ntbankm.eq.0) ntbank=0 - nstep=0 - nft=0 - do i=1,mxio - ibank(i)=0 - jbank(i)=0 - enddo - else - call restart_write -!!bankt call read_bankt(jlee,nft,cutdifr) - call read_bank(jlee,nft,cutdifr) - call read_rbank(jlee,adif) - if(iref.ne.0) call from_int(1,0,idum) - endif - - nstmax=nstmax+nstep - ntrial=n1+n2+n3+n4+n5+n6+n7+n8 - ntry=ntrial+1 - ntry=ntry*nseed - -! ntrial : number of trial conformations per seed. -! ntry : total number of trial conformations including seed conformations. - - idum2=-123 -! imax=2**31-1 - imax=huge(0) - ENDIF - - call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr) -!ccccccccccccccccccccccccccccccccccccccc - do 300 jlee=1,jend -!ccccccccccccccccccccccccccccccccccccccc - 331 continue - IF (ME.EQ.KING) THEN - if(sync_iter) goto 333 - idum=- ran2(idum2)*imax - if(jlee.lt.jstart) goto 300 - -! Restart the random number generator for conformation generation - - if(irestart.gt.0) then - idum2=idum2+nstep - if(idum2.le.0) idum2=-idum2+1 - idum=- ran2(idum2)*imax - endif - - idumm=idum - call vrndst(idumm) - - open(icsa_seed,file=csa_seed,status="old") - write(icsa_seed,*) "jlee : ",jlee - close(icsa_seed) - - call history_append - write(icsa_history,*) "number of procs is ",nodes - write(icsa_history,*) jlee,idum,idum2 - close(icsa_history) - -!ccccccccccccccccccccccccccccccccccccccccccccccc - 333 icycle=0 - - call history_append - write(icsa_history,*) "nbank is ",nbank - close(icsa_history) - - if(irestart.eq.1) goto 111 - if(irestart.eq.2) then - icycle=0 - do i=1,nbank - ibank(i)=1 - enddo - do i=nbank+1,nbank+nconf - ibank(i)=0 - enddo - endif - -! start energy minimization - nconfr=max0(nconf+nadd,nodes-1) - if (sync_iter) nconf_in=0 -! king-emperor - feed input and sort output - write (iout,*) "NCONF_IN",nconf_in - m=0 - if (nconf_in.gt.0) then -! al 7/2/00 - added possibility to read in some of the initial conformations - do m=1,nconf_in - read (intin,'(i5)',end=11,err=12) iconf - 12 continue - write (iout,*) "write READ_ANGLES",iconf,m - call read_angles(intin,*11) - if (iref.eq.0) then - mm=m - else - mm=m+1 - endif - do j=2,nres-1 - dihang_in(1,j,1,mm)=theta(j+1) - dihang_in(2,j,1,mm)=phi(j+2) - dihang_in(3,j,1,mm)=alph(j) - dihang_in(4,j,1,mm)=omeg(j) - enddo - enddo ! m - goto 13 - 11 write (iout,*) nconf_in," conformations requested, but only",& - m-1," found in the angle file." - nconf_in=m-1 - 13 continue - m=nconf_in - write (iout,*) nconf_in,& - " initial conformations have been read in." - endif - if (iref.eq.0) then - if (nconfr.gt.nconf_in) then - call make_ranvar(nconfr,m,idum) - write (iout,*) nconfr-nconf_in,& - " conformations have been generated randomly." - endif - else - nconfr=nconfr*2 - call from_int(nconfr,m,idum) -! call from_pdb(nconfr,idum) - endif - write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr - write (*,*) 'Exitted from make_ranvar nconfr=',nconfr - do m=1,nconfr - write (iout,*) 'Initial conformation',m - write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1) - enddo - write(iout,*)'Calling FEEDIN NCONF',nconfr - time1i=MPI_WTIME() - call feedin(nconfr,nft) - write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i - call history_append - write(icsa_history,*) jlee,nft,nbank - write(icsa_history,851) (etot(i),i=1,nconfr) - write(icsa_history,850) (rmsn(i),i=1,nconfr) - write(icsa_history,850) (pncn(i),i=1,nconfr) - write(icsa_history,*) - close(icsa_history) - ELSE -! To minimize input conformation (bank conformation) -! Output to $mol.reminimized - if (irestart.lt.0) then - call reminimize(jlee) - return - endif - if (irestart.eq.1) goto 111 -! soldier - perform energy minimization - 334 call minim_jlee - ENDIF - -!cccccccccccccccccccccccccccccccccc -! need to syncronize all procs - call mpi_barrier(CG_COMM,ierr) - if (ierr.ne.0) then - print *, ' cannot synchronize MPI' - stop - endif -!cccccccccccccccccccccccccccccccccc - - IF (ME.EQ.KING) THEN - -! print *,"ok after minim" - nstep=nstep+nconf - if(irestart.eq.2) then - nbank=nbank+nconf -! ntbank=ntbank+nconf - if(ntbank.gt.ntbankm) ntbank=ntbankm - endif -! print *,"ok before indexx" - if(iref.eq.0) then - call indexx(nconfr,etot,indx) - else -! cc/al 7/6/00 - do k=1,nconfr - indx(k)=k - enddo - call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1)) - do k=nconf_in+1,nconfr - indx(k)=indx(k)+nconf_in - enddo -! cc/al -! call indexx(nconfr,rmsn,indx) - endif -! print *,"ok after indexx" - do im=1,nconf - m=indx(im) - if (m.gt.mxio .or. m.lt.1) then - write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - jbank(im+nbank-nconf)=0 - bene(im+nbank-nconf)=etot(m) - rene(im+nbank-nconf)=etot(m) -!!bankt btene(im)=etot(m) -! - brmsn(im+nbank-nconf)=rmsn(m) - bpncn(im+nbank-nconf)=pncn(m) - rrmsn(im+nbank-nconf)=rmsn(m) - rpncn(im+nbank-nconf)=pncn(m) - if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then - write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,& - ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) - rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) -!!bankt btvar(i,j,k,im)=dihang(i,j,k,m) -! - enddo - enddo - enddo - if(iref.eq.1) then - if(brmsn(im+nbank-nconf).gt.rmscut.or. & - bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9 - endif - if(vdisulf) then - bvar_ns(im+nbank-nconf)=ns-2*nss - k=0 - do i=1,ns - j=1 - do while( iss(i).ne.ihpb(j)-nres .and. & - iss(i).ne.jhpb(j)-nres .and. j.le.nss) - j=j+1 - enddo - if (j.gt.nss) then - k=k+1 - bvar_s(k,im+nbank-nconf)=iss(i) - endif - enddo - endif - bvar_nss(im+nbank-nconf)=nss - do i=1,nss - bvar_ss(1,i,im+nbank-nconf)=ihpb(i) - bvar_ss(2,i,im+nbank-nconf)=jhpb(i) - enddo - enddo - ENDIF - - 111 continue - - IF (ME.EQ.KING) THEN - - call find_max - call find_min - - call get_diff - if(nbank.eq.nconf.and.irestart.eq.0) then - adif=avedif - endif - - cutdif=adif/cut1 - ctdif1=adif/cut2 - -!d print *,"adif,xctdif,cutdifr" -!d print *,adif,xctdif,cutdifr - nst=ntotal/ntrial/nseed - xctdif=(cutdif/ctdif1)**(-1.0/nst) - if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr) -! print *,"ok after estimate" - - irestart=0 - - call write_rbank(jlee,adif,nft) - call write_bank(jlee,nft) -!!bankt call write_bankt(jlee,nft) -! call write_bank1(jlee) - call history_append - write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1 - write(icsa_history,851) (bene(i),i=1,nbank) - write(icsa_history,850) (brmsn(i),i=1,nbank) - write(icsa_history,850) (bpncn(i),i=1,nbank) - close(icsa_history) - 850 format(10f8.3) - 851 format(5e15.6) - - ifar=nseed/4*3+1 - ifar=nseed+1 - ENDIF - - - finished=.false. - iter = 0 - irecv = 0 - isent =0 - ifrom= 0 - time0i=MPI_WTIME() - time1i=time0i - time_start_c=time0i - if (.not.sync_iter) then - time_start=time0i - nft00=nft - else - sync_iter=.false. - endif - nft00_c=nft - nft0i=nft - -!cccccccccccccccccccccccccccccccccccccc - do while (.not. finished) -!cccccccccccccccccccccccccccccccccccccc -!rc print *,"iter ", iter,' isent=',isent - - IF (ME.EQ.KING) THEN -! start energy minimization - - if (isent.eq.0) then -! king-emperor - select seeds & make var & feed input -!d print *,'generating new conf',ntrial,MPI_WTIME() - call select_is(nseed,ifar,idum) - - open(icsa_seed,file=csa_seed,status="old") - write(icsa_seed,39) & - jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed) - close(icsa_seed) - call history_append - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& - ebmin,ebmax,nft,iuse,nbank,ntbank - close(icsa_history) - - - - call make_var(ntry,idum,iter) -!d print *,'new trial generated',ntrial,MPI_WTIME() - time2i=MPI_WTIME() - write (iout,'(a20,i4,f12.2)') & - 'Time for make trial',iter+1,time2i-time1i - endif - -!rc write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial -!rc call feedin(ntry,nft) - - isent=isent+1 - if (isent.ge.nodes.or.iter.gt.0) then -!t print *,'waiting ',MPI_WTIME() - irecv=irecv+1 - call recv(0,ifrom,xout,eout,ind,timeout) -!t print *,' ',irecv,' received from',ifrom,MPI_WTIME() - else - ifrom=ifrom+1 - endif - -!t print *,'sending to',ifrom,MPI_WTIME() - call send(isent,ifrom,iter) -!t print *,isent,' sent ',MPI_WTIME() - -! store results ----------------------------------------------- - if (isent.ge.nodes.or.iter.gt.0) then - nft=nft+ind(3) - movernx(irecv)=iabs(ind(5)) - call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) - if(vdisulf) then - nss_out(irecv)=nss - do i=1,nss - iss_out(i,irecv)=ihpb(i) - jss_out(i,irecv)=jhpb(i) - enddo - endif - if(iw_pdb.gt.0) & - call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) - endif -!-------------------------------------------------------------- - if (isent.eq.ntry) then - time1i=MPI_WTIME() - write (iout,'(a18,f12.2,a14,f10.2)') & - 'Nonsetup time ',time1i-time_start_c,& - ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c) - write (iout,'(a14,i4,f12.2,a14,f10.2)') & - 'Time for iter ',iter+1,time1i-time0i,& - ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i) - time0i=time1i - nft0i=nft - cutdif=cutdif*xctdif - if(cutdif.lt.ctdif1) cutdif=ctdif1 - if (iter.eq.0) then - print *,'UPDATING ',ntry-nodes+1,irecv - write(iout,*) 'UPDATING ',ntry-nodes+1 - iter=iter+1 -!----------------- call update(ntry-nodes+1) ------------------- - nstep=nstep+ntry-nseed-(nodes-1) - call refresh_bank(ntry-nodes+1) -!!bankt call refresh_bankt(ntry-nodes+1) - else -!----------------- call update(ntry) --------------------------- - iter=iter+1 - print *,'UPDATING ',ntry,irecv - write(iout,*) 'UPDATING ',ntry - nstep=nstep+ntry-nseed - call refresh_bank(ntry) -!!bankt call refresh_bankt(ntry) - endif -!----------------------------------------------------------------- - - call write_bank(jlee,nft) -!!bankt call write_bankt(jlee,nft) - call find_min - - time1i=MPI_WTIME() - write (iout,'(a20,i4,f12.2)') & - 'Time for refresh ',iter,time1i-time0i - - if(ebmin.lt.estop) finished=.true. - if(icycle.gt.icmax) then - call write_bank1(jlee) - do i=1,nbank - ibank(i)=2 - ibank(i)=1 - enddo - nbank=nbank+nconf - if(nbank.gt.1000) then - finished=.true. - else -!rc goto 333 - sync_iter=.true. - endif - endif - if(nstep.gt.nstmax) finished=.true. - - if(finished.or.sync_iter) then - do ij=1,nodes-1 - call recv(1,ifrom,xout,eout,ind,timeout) - if (timeout) then - nstep=nstep+ij-1 - print *,'ERROR worker is not responding' - write(iout,*) 'ERROR worker is not responding' - time1i=MPI_WTIME()-time_start_c - print *,'End of cycle, master time for ',iter,' iters ',& - time1i,'sec, Eval/s ',(nft-nft00_c)/time1i - write (iout,*) 'End of cycle, master time for ',iter,& - ' iters ',time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i - print *,'UPDATING ',ij-1 - write(iout,*) 'UPDATING ',ij-1 - call flush(iout) - call refresh_bank(ij-1) -!!bankt call refresh_bankt(ij-1) - goto 1002 - endif -! print *,'node ',ifrom,' finished ',ij,nft - write(iout,*) 'node ',ifrom,' finished ',ij,nft - call flush(iout) - nft=nft+ind(3) - movernx(ij)=iabs(ind(5)) - call getx(ind,xout,eout,cout,rad,iw_pdb,ij) - if(vdisulf) then - nss_out(ij)=nss - do i=1,nss - iss_out(i,ij)=ihpb(i) - jss_out(i,ij)=jhpb(i) - enddo - endif - if(iw_pdb.gt.0) & - call write_csa_pdb(xout,eout,nft,ij,iw_pdb) - enddo - nstep=nstep+nodes-1 -!rc print *,'---------bcast finished--------',finished - time1i=MPI_WTIME()-time_start_c - print *,'End of cycle, master time for ',iter,' iters ',& - time1i,'sec, Eval/s ',(nft-nft00_c)/time1i - write (iout,*) 'End of cycle, master time for ',iter,& - ' iters ',time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i - -!timeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) -!timeout call mpi_bcast(sync_iter,1,mpi_logical,0, -!timeout & CG_COMM,ierr) - do ij=1,nodes-1 - tstart=MPI_WTIME() - call mpi_issend(finished,1,mpi_logical,ij,idchar,& - CG_COMM,ireq,ierr) - call mpi_issend(sync_iter,1,mpi_logical,ij,idchar,& - CG_COMM,ireq2,ierr) - flag=.false. - timeout1=.false. - do while(.not. (flag .or. timeout1)) - call MPI_TEST(ireq2,flag,muster,ierr) - tend1=MPI_WTIME() - if(tend1-tstart.gt.60) then - print *,'ERROR worker ',ij,' is not responding' - write(iout,*) 'ERROR worker ',ij,' is not responding' - timeout1=.true. - endif - enddo - if(timeout1) then - write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart - timeout=.true. - else - write(iout,*) 'worker ',ij,' OK ',tend1-tstart - endif - enddo - print *,'UPDATING ',nodes-1,ij - write(iout,*) 'UPDATING ',nodes-1 - call refresh_bank(nodes-1) -!!bankt call refresh_bankt(nodes-1) - 1002 continue - call write_bank(jlee,nft) -!!bankt call write_bankt(jlee,nft) - call find_min - - do i=0,mxmv - do j=1,3 - nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) - nstatnx(i,j)=0 - enddo - enddo - - write(iout,*)'### Total stats:' - do i=0,mxmv - if(nstatnx_tot(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') & - '### N',i,' total=',nstatnx_tot(i,1),& - ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc',& - (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) - else - write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') & - '###N',i,' total=',nstatnx_tot(i,1),& - ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc',& - (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) - endif - else - if (i.le.9) then - write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') & - '### N',i,' total=',nstatnx_tot(i,1),& - ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),& - ' %acc',0.0 - else - write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') & - '###N',i,' total=',nstatnx_tot(i,1),& - ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),& - ' %acc',0.0 - endif - endif - enddo - - endif - if(sync_iter) goto 331 - - 39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x))) - 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) - 43 format(10i8) - 44 format('jlee =',i3,':',4f10.1,' E =',f8.3,i7,i10) - - isent=0 - irecv=0 - endif - ELSE -! soldier - perform energy minimization - call minim_jlee - print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start - write (iout,*) 'End of minim, proc',me,'time ',& - MPI_WTIME()-time_start - call flush(iout) -!timeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) -!timeout call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr) - call mpi_recv(finished,1,mpi_logical,0,idchar,& - CG_COMM,muster,ierr) - call mpi_recv(sync_iter,1,mpi_logical,0,idchar,& - CG_COMM,muster,ierr) - if(sync_iter) goto 331 - ENDIF - -!cccccccccccccccccccccccccccccccccccccc - enddo -!cccccccccccccccccccccccccccccccccccccc - - IF (ME.EQ.KING) THEN - call history_append - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& - ebmin,ebmax,nft,iuse,nbank,ntbank - - write(icsa_history,44) jlee,0.0,0.0,0.0,& - 0.0,ebmin,nstep,nft - write(icsa_history,*) - close(icsa_history) - - time1i=MPI_WTIME()-time_start - print *,'End of RUN, master time ',& - time1i,'sec, Eval/s ',(nft-nft00)/time1i - write (iout,*) 'End of RUN, master time ',& - time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00)/time1i - - if(timeout) then - write(iout,*) '!!!! ERROR worker was not responding' - write(iout,*) '!!!! cannot finish work normally' - write(iout,*) 'Processor0 is calling MPI_ABORT' - print *,'!!!! ERROR worker was not responding' - print *,'!!!! cannot finish work normally' - print *,'Processor0 is calling MPI_ABORT' - call flush(iout) - call mpi_abort(mpi_comm_world, 111, ierr) - endif - ENDIF - -!ccccccccccccccccccccccccccccc - 300 continue -!ccccccccccccccccccccccccccccc - - return - end subroutine together -!----------------------------------------------------------------------------- - subroutine feedin(nconf,nft) - - use MPI_data - use geometry_data, only:nvar - use io, only:write_csa_pdb -! sends out starting conformations and receives results of energy minimization -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' - include 'mpif.h' - real(kind=8),dimension(6*nres) :: xin,xout !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout - real(kind=8),dimension(2) :: cout - integer,dimension(9) :: ind - integer,dimension(12) :: info - integer,dimension(mpi_status_size) :: muster -! include 'COMMON.SETUP' - real(kind=8),parameter :: rad=1.745329252d-2 - integer :: j,nconf,nft,mm,n,ierror,ierrcode,ierr,iw_pdb,& - man - - print *,'FEEDIN: NCONF=',nconf - mm=0 -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if (nconf .lt. nodes-1) then - write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1',& - nconf,nodes-1 - write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1',& - nconf,nodes-1 - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do n=1,nconf -! pull out external and internal variables for next start - call putx(xin,n,rad) -! write (iout,*) 'XIN from FEEDIN N=',n -! write(iout,'(8f10.4)') (xin(j),j=1,nvar) - mm=mm+1 - if (mm.lt.nodes) then -! feed task to soldier -! print *, ' sending input for start # ',n - info(1)=n - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,& - ierr) - call mpi_send(xin,nvar,mpi_double_precision,mm,& - idreal,CG_COMM,ierr) - else -! find an available soldier - call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,& - CG_COMM,muster,ierr) -! print *, ' receiving output from start # ',ind(1) - man=muster(mpi_source) -! receive final energies and variables - nft=nft+ind(3) - call mpi_recv(eout,1,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif - call mpi_recv(xout,nvar,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr -! feed next task to soldier -! print *, ' sending input for start # ',n - info(1)=n - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - info(7)=0 - info(8)=0 - info(9)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,& - ierr) - call mpi_send(xin,nvar,mpi_double_precision,man,& - idreal,CG_COMM,ierr) -! retrieve latest results - call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) - if(iw_pdb.gt.0) & - call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) - endif - enddo -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! no more input -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - do j=1,nodes-1 -! wait for a soldier - call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,& - CG_COMM,muster,ierr) -!rc if (ierr.ne.0) go to 30 -! print *, ' receiving output from start # ',ind(1) - man=muster(mpi_source) -! receive final energies and variables - nft=nft+ind(3) - call mpi_recv(eout,1,& - mpi_double_precision,man,idreal,& - CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif -!rc if (ierr.ne.0) go to 30 - call mpi_recv(xout,nvar,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr -!rc if (ierr.ne.0) go to 30 -! halt soldier - info(1)=0 - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,& - ierr) -! retrieve results - call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) - if(iw_pdb.gt.0) & - call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) - enddo -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - return - 10 print *, ' dispatching error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 20 print *, ' communication error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 30 print *, ' receiving error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - - return - end subroutine feedin -!----------------------------------------------------------------------------- - subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k) - - use geometry_data - use energy_data - use compare, only: contact_fract - use MPI_data - include 'mpif.h' -! receives and stores data from soldiers -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.CONTACTS' - integer,dimension(9) :: ind - real(kind=8),dimension(6*nres) :: xout !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout -!jlee - real(kind=8) :: przes(3),obr(3,3),cout(2) - logical :: non_conv - integer :: iw_pdb,k,j,ierror,ierrcode - real(kind=8) :: rad,co -!jlee - iw_pdb=2 - if (k.gt.mxio .or. k.lt.1) then - write (iout,*) & - 'ERROR - dimensions of ANGMIN have been exceeded K=',k - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -! store ind() - do j=1,9 - indb(k,j)=ind(j) - enddo -! store energies - etot(k)=eout(1) -! retrieve dihedral angles etc - call var_to_geom(nvar,xout) - do j=2,nres-1 - dihang(1,j,1,k)=theta(j+1) - dihang(2,j,1,k)=phi(j+2) - dihang(3,j,1,k)=alph(j) - dihang(4,j,1,k)=omeg(j) - enddo - dihang(2,nres-1,1,k)=0.0d0 -!jlee - if(iref.eq.0) then - iw_pdb=1 -!d write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') -!d & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ', -!d & ind(5),ind(4) - return - endif - call chainbuild -! call dihang_to_c(dihang(1,1,1,k)) -! call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv) -! call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv) -! call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup), -! & nsup,przes,obr,non_conv) -! rmsn(k)=dsqrt(rms) - - call rmsd_csa(rmsn(k)) - call contact(.false.,ncont,icont,co) - pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref) - -!d write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5 -!d & ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') -!d & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ', -!d & rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ', -!d & ind(5),ind(4) - - - if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0 - return - end subroutine getx -!----------------------------------------------------------------------------- - subroutine putx(xin,n,rad) - - use geometry_data -! gets starting variables -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' - integer :: n,m,j - real(kind=8),dimension(6*nres) :: xin !(maxvar) (maxvar=6*maxres) - real(kind=8) :: rad - -! pull out starting values for variables -! write (iout,*)'PUTX: N=',n - do m=1,numch -! write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1) - do j=2,nres-1 - theta(j+1)=dihang_in(1,j,m,n) - phi(j+2)=dihang_in(2,j,m,n) - alph(j)=dihang_in(3,j,m,n) - omeg(j)=dihang_in(4,j,m,n) - enddo - enddo -! set up array of variables - call geom_to_var(nvar,xin) -! write (iout,*) 'xin in PUTX N=',n -! call intout -! write (iout,'(8f10.4)') (xin(i),i=1,nvar) - return - end subroutine putx -!----------------------------------------------------------------------------- - subroutine putx2(xin,iff,n) - - use geometry_data -! gets starting variables -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' - integer :: n,m,j,i - real(kind=8),dimension(6*nres) :: xin !(maxvar) (maxvar=6*maxres) - integer,dimension(nres) :: iff !(maxres) - -! pull out starting values for variables - do m=1,numch - do j=2,nres-1 - theta(j+1)=dihang_in2(1,j,m,n) - phi(j+2)=dihang_in2(2,j,m,n) - alph(j)=dihang_in2(3,j,m,n) - omeg(j)=dihang_in2(4,j,m,n) - enddo - enddo -! set up array of variables - call geom_to_var(nvar,xin) - - do i=1,nres - iff(i)=iff_in(i,n) - enddo - return - end subroutine putx2 -!----------------------------------------------------------------------------- - subroutine prune_bank(p_cut) - - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.TIME1' -! include 'COMMON.SETUP' - integer :: k,j,i,m,ip,nprune - real(kind=8) :: p_cut,diff,ddmin -!--------------------------- -! This subroutine prunes bank conformations using p_cut -!--------------------------- - - nprune=0 - nprune=nprune+1 - m=1 - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang(i,j,k,nprune)=bvar(i,j,k,m) - enddo - enddo - enddo - bene(nprune)=bene(m) - brmsn(nprune)=brmsn(m) - bpncn(nprune)=bpncn(m) - - do m=2,nbank - ddmin=9.d190 - do ip=1,nprune - call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) - if(diff.lt.p_cut) goto 100 - if(diff.lt.ddmin) ddmin=diff - enddo - nprune=nprune+1 - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang(i,j,k,nprune)=bvar(i,j,k,m) - enddo - enddo - enddo - bene(nprune)=bene(m) - brmsn(nprune)=brmsn(m) - bpncn(nprune)=bpncn(m) - 100 continue - write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin - enddo - nbank=nprune - print *, 'Pruning :',m,nprune,p_cut - call write_bank(0,0) - - return - end subroutine prune_bank -!----------------------------------------------------------------------------- - subroutine reminimize(jlee) - - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.TIME1' -! include 'COMMON.SETUP' - integer :: i,j,k,jlee,index,nft,ntry -!--------------------------- -! This subroutine re-minimizes bank conformations: -!--------------------------- - - ntry=nbank - - call find_max - call find_min - - if (me.eq.king) then - open(icsa_history,file=csa_history,status="old") - write(icsa_history,*) "Re-minimization",nodes,"nodes" - write(icsa_history,851) (bene(i),i=1,nbank) - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& - ebmin,ebmax,nft,iuse,nbank,ntbank - close(icsa_history) - do index=1,ntry - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,index) - enddo - enddo - enddo - enddo - nft=0 - call feedin(ntry,nft) - else - call minim_jlee - endif - - call find_max - call find_min - - if (me.eq.king) then - do i=1,ntry - call replace_bvar(i,i) - enddo - open(icsa_history,file=csa_history,status="old") - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,& - ebmin,ebmax,nft,iuse,nbank,ntbank - write(icsa_history,851) (bene(i),i=1,nbank) - close(icsa_history) - call write_bank_reminimized(jlee,nft) - endif - - 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) - 851 format(5e15.6) - 850 format(5e15.10) -! 850 format(10f8.3) - - return - end subroutine reminimize -!----------------------------------------------------------------------------- - subroutine send(n,mm,it) - - use MPI_data - use geometry_data, only: nvar - use control_data, only: vdisulf -! sends out starting conformation for minimization -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' - include 'mpif.h' - real(kind=8),dimension(6*nres) :: xin,xout,xin2 !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout - real(kind=8),dimension(2) :: cout - integer,dimension(9) :: ind - integer,dimension(nres) :: iff !(maxres) - integer,dimension(12) :: info - integer,dimension(mpi_status_size) :: muster -! include 'COMMON.SETUP' - real(kind=8),parameter :: rad=1.745329252d-2 - integer :: n,mm,it,ierr - - if (isend2(n).eq.0) then -! pull out external and internal variables for next start - call putx(xin,n,rad) - info(1)=n - info(2)=it - info(3)=movenx(n) - info(4)=nss_in(n) - info(5)=parent(1,n) - info(6)=parent(2,n) - - if (movenx(n).eq.14.or.movenx(n).eq.17) then - info(7)=idata(1,n) - info(8)=idata(2,n) - else if (movenx(n).eq.16) then - info(7)=idata(1,n) - info(8)=idata(2,n) - info(10)=idata(3,n) - info(11)=idata(4,n) - info(12)=idata(5,n) - else - info(7)=0 - info(8)=0 - info(10)=0 - info(11)=0 - info(12)=0 - endif - - if (movenx(n).eq.15) then - info(9)=parent(3,n) - else - info(9)=0 - endif - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,& - ierr) - call mpi_send(xin,nvar,mpi_double_precision,mm,& - idreal,CG_COMM,ierr) - else -! distfit & minimization for n7 move - info(1)=-n - info(2)=it - info(3)=movenx(n) - info(4)=nss_in(n) - info(5)=parent(1,n) - info(6)=parent(2,n) - info(7)=0 - info(8)=0 - info(9)=0 - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,& - ierr) - call putx2(xin,iff,isend2(n)) - call mpi_send(xin,nvar,mpi_double_precision,mm,& - idreal,CG_COMM,ierr) - call mpi_send(iff,nres,mpi_integer,mm,& - idint,CG_COMM,ierr) - call putx(xin2,n,rad) - call mpi_send(xin2,nvar,mpi_double_precision,mm,& - idreal,CG_COMM,ierr) - endif - if (vdisulf.and.nss_in(n).ne.0) then - call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm,& - idint,CG_COMM,ierr) - call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm,& - idint,CG_COMM,ierr) - endif - return - end subroutine send -!----------------------------------------------------------------------------- - subroutine recv(ihalt,man,xout,eout,ind,tout) - - use MPI_data - use energy_data - use geometry_data, only: nvar - use control_data, only: vdisulf -! receives results of energy minimization -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -! include 'COMMON.SBRIDGE' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' - include 'mpif.h' - real(kind=8),dimension(6*nres) :: xin,xout !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: eout - real(kind=8),dimension(2) :: cout - integer,dimension(9) :: ind - integer,dimension(12) :: info - integer,dimension(mpi_status_size) :: muster -! include 'COMMON.SETUP' - logical :: tout,flag - real(kind=8) :: tstart,tend1 - real(kind=8),parameter :: twait=600.0d0 - integer :: ihalt,man,ierr - -! find an available soldier - tout=.false. - flag=.false. - tstart=MPI_WTIME() - do while(.not. (flag .or. tout)) - call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, & - muster,ierr) - tend1=MPI_WTIME() - if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true. -!_error if(tend1-tstart.gt.twait) tout=.true. - enddo - if (tout) then - write(iout,*) 'ERROR = timeout for recv ',tend1-tstart - call flush(iout) - return - endif - man=muster(mpi_source) - -!timeout call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, -!timeout * CG_COMM,muster,ierr) -! print *, ' receiving output from start # ',ind(1) -!t print *,'receiving ',MPI_WTIME() -!timeout man=muster(mpi_source) - call mpi_recv(ind,9,mpi_integer,man,idint,& - CG_COMM,muster,ierr) -!timeout -! receive final energies and variables - call mpi_recv(eout,1,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif - call mpi_recv(xout,nvar,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr - if(vdisulf) nss=ind(6) - if(vdisulf.and.nss.ne.0) then - call mpi_recv(ihpb,nss,mpi_integer,& - man,idint,CG_COMM,muster,ierr) - call mpi_recv(jhpb,nss,mpi_integer,& - man,idint,CG_COMM,muster,ierr) - endif -! halt soldier - if(ihalt.eq.1) then -! print *,'sending halt to ',man - write(iout,*) 'sending halt to ',man - info(1)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) - endif - return - end subroutine recv -!----------------------------------------------------------------------------- - subroutine history_append - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,position="append") -#else - open(icsa_history,file=csa_history,access="append") -#endif - return - end subroutine history_append -!----------------------------------------------------------------------------- - subroutine alloc_CSA_arrays - - use energy_data, only: ns - - mxgr=2*nres - - if(.not.allocated(bfrag)) allocate(bfrag(4,nres/3)) -! commom.bank -! common/varin/ -!el allocate(dihang_in(mxang,nres,mxch,mxio)) !(mxang,maxres,mxch,mxio) - allocate(dihang_in(mxang,nres,mxch,5000)) !(mxang,maxres,mxch,mxio) - allocate(nss_in(mxio)) !(mxio) - allocate(iss_in(ns,mxio),jss_in(ns,mxio)) !(maxss,mxio) -! common/minvar/ - allocate(dihang(mxang,nres,mxch,mxio)) !(mxang,maxres,mxch,mxio) - allocate(rmsn(mxio),pncn(mxio)) !(mxio) - allocate(etot(mxio)) !(mxio) - allocate(nss_out(mxio)) !(mxio) - allocate(iss_out(ns,mxio),jss_out(ns,mxio)) !(maxss,mxio) -! common/bank/ - allocate(rvar(mxang,nres,mxch,mxio),bvar(mxang,nres,mxch,mxio)) !(mxang,maxres,mxch,mxio) - allocate(bene(mxio),rene(mxio),brmsn(mxio),rrmsn(mxio)) - allocate(bpncn(mxio),rpncn(mxio)) !(mxio) - allocate(ibank(mxio),is(mxio),jbank(mxio)) !(mxio) - allocate(dij(mxio,mxio)) !(mxio,mxio) -! common/bank_disulfid/ - allocate(bvar_nss(mxio),bvar_ns(mxio)) !(mxio) - allocate(bvar_s(ns,mxio)) !(maxss,mxio) - allocate(bvar_ss(2,ns,mxio)) !(2,maxss,mxio) -! common/mvstat/ - allocate(movenx(mxio),movernx(mxio)) !(mxio) - allocate(nstatnx(0:mxmv,3),nstatnx_tot(0:mxmv,3)) !(0:mxmv,3) - allocate(indb(mxio,9)) !(mxio,9) - allocate(parent(3,mxio)) !(3,mxio) -! common/send2/ - allocate(isend2(mxio)) !(mxio) - allocate(iff_in(nres,mxio2)) !(maxres,mxio2) - allocate(dihang_in2(mxang,nres,mxch,mxio2)) !(mxang,maxres,mxch,mxio2) - allocate(idata(5,mxio)) !(5,mxio) -! common.csa -! common/alphaa/ - allocate(ngroup(mxgr)) !(mxgr) - allocate(igroup(3,mxang,mxgr)) !(3,mxang,mxgr) -! common.distfit -! COMMON /frag/ - allocate(bvar_frag(mxio,6)) !(mxio,6) - allocate(hvar_frag(mxio,3),lvar_frag(mxio,3),svar_frag(mxio,3)) !(mxio,3) - allocate(avar_frag(mxio,5)) !(mxio,5) -! commom.hairpin -! common /spinka/ - allocate(nharp_seed(nseed),nharp_use(nseed)) !(max_seed) - allocate(iharp_seed(4,nres/3,nseed)) !(4,maxres/3,max_seed) - allocate(iharp_use(0:4,nres/3,nseed)) !(0:4,maxres/3,max_seed) - - return - end subroutine alloc_CSA_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module csa diff --git a/source/unres/MCM_MD.F90 b/source/unres/MCM_MD.F90 new file mode 100644 index 0000000..afb31bb --- /dev/null +++ b/source/unres/MCM_MD.F90 @@ -0,0 +1,3514 @@ + module mcm_md +!----------------------------------------------------------------------------- + use io_units + use names + use math + use geometry_data, only: nres,nvar,rad2deg + use random, only: iran_num,ran_number + use MD_data + use MCM_data + use geometry + use energy + + implicit none +!----------------------------------------------------------------------------- +! Max. number of move types in MCM +! integer,parameter :: maxmovetype=4 +!----------------------------------------------------------------------------- +! Max. number of conformations in Master's cache array + integer,parameter :: max_cache=10 +!----------------------------------------------------------------------------- +! Max. number of stored confs. in MC/MCM simulation +! integer,parameter :: maxsave=20 +!----------------------------------------------------------------------------- +! Number of threads in deformation + integer,parameter :: max_thread=4, max_thread2=2*max_thread +!----------------------------------------------------------------------------- +! Number of structures to compare at t=0 + integer,parameter :: max_threadss=8,max_threadss2=2*max_threadss +!----------------------------------------------------------------------------- +! Max. number of conformations in the pool + integer,parameter :: max_pool=10 +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! commom.cache +! common /cache/ + integer :: ncache +! integer,dimension(max_cache) :: CachSrc nie używane +! integer,dimension(max_cache) :: isent,iused +! logical :: cache_update +! real(kind=8),dimension(max_cache) :: ecache +! real(kind=8),dimension(:,:),allocatable :: xcache !(maxvar,max_cache) +!----------------------------------------------------------------------------- +! common.mce +! common /mce/ +! real(kind=8) :: emin,emax + real(kind=8),dimension(:),allocatable :: entropy !(-max_ene-4:max_ene) + real(kind=8),dimension(:),allocatable :: nhist !(-max_ene:max_ene) + real(kind=8),dimension(:),allocatable :: nminima !(maxsave) +! logical :: ent_read + logical :: multican + integer :: indminn,indmaxx +! common /pool/ + integer :: npool +! real(kind=8) :: pool_fraction + real(kind=8),dimension(:,:),allocatable :: xpool !(maxvar,max_pool) + real(kind=8),dimension(:),allocatable :: epool !(max_pool) +! common /mce_counters/ +!------------------------------------------------------------------------------ +!... Following COMMON block contains variables controlling motion. +!------------------------------------------------------------------------------ +! common /move/ +! real(kind=8),dimension(0:MaxMoveType) :: sumpro_type !(0:MaxMoveType) + real(kind=8),dimension(:),allocatable :: sumpro_bond !(0:maxres) + integer :: koniecl,Nbm,MaxSideMove!,nmove + integer,dimension(:),allocatable :: nbond_move,nbond_acc !(maxres) +! integer,dimension(-1:MaxMoveType+1) :: moves,moves_acc !(-1:MaxMoveType+1) +! common /accept_stats/ +! integer :: nacc_tot + integer,dimension(:),allocatable :: nacc_part !(0:MaxProcs) !el nie uzywane??? +! common /windows/ +! integer :: nwindow +! integer,dimension(:),allocatable :: winstart,winend,winlen !(maxres) +! common /moveID/ +! character(len=16),dimension(-1:MaxMoveType+1) :: MovTypID !(-1:MaxMoveType+1) +!------------------------------------------------------------------------------ +!... koniecl - the number of bonds to be considered "end bonds" subjected to +!... end moves; +!... Nbm - The maximum length of N-bond segment to be moved; +!... MaxSideMove - maximum number of side chains subjected to local moves +!... simultaneously; +!... nmove - the current number of attempted moves; +!... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... +!... moves; +!... nendmove - number of endmoves; +!... nbackmove - number of backbone moves; +!... nsidemove - number of local side chain moves; +!... sumpro_type(*) - array that stores the lower and upper boundary of the +!... random-number range that determines the type of move +!... (N-bond, backbone or side chain); +!... sumpro_bond(*) - array that stores the probabilities to perform bond +!... moves of consecutive segment length. +!... winstart(*) - the starting position of the perturbation window; +!... winend(*) - the end position of the perturbation window; +!... winlen(*) - length of the perturbation window; +!... nwindow - the number of perturbation windows (0 - entire chain). +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! compare_s1.F +!----------------------------------------------------------------------------- + subroutine compare_s1(n_thr,num_thread_save,energyx,x,icomp,enetbss,& + coordss,rms_d,modif,iprint) + +! This subroutine compares the new conformation, whose variables are in X +! with the previously accumulated conformations whose energies and variables +! are stored in ENETBSS and COORDSS, respectively. The meaning of other +! variables is as follows: +! +! N_THR - on input the previous # of accumulated confs, on output the current +! # of accumulated confs. +! N_REPEAT - an array that indicates how many times the structure has already +! been used to start the reversed-reversing procedure. Addition of +! a new structure replacement of a structure with a similar, but +! lower-energy structure resets the respective entry in N_REPEAT to zero +! I9 - output unit +! ENERGYX,X - the energy and variables of the new conformations. +! ICOMP - comparison result: +! 0 - the new structure is similar to one of the previous ones and does +! not have a remarkably lower energy and is therefore rejected; +! 1 - the new structure is different and is added to the set, because +! there is still room in the COORDSS and ENETBSS arrays; +! 2 - the new structure is different, but higher in energy than any +! previous one and is therefore rejected +! 3 - there is no more room in the COORDSS and ENETBSS arrays, but +! the new structure is lower in energy than at least the highest- +! energy previous structure and therefore replaces it. +! 9 - the new structure is similar to a number of previous structures, +! but has a remarkably lower energy than any of them; therefore +! replaces all these structures; +! MODIF - a logical variable that shows whether to include the new structure +! in the set of accumulated structures + +! implicit real*8 (a-h,o-z) + use geometry_data + use regularize_, only:fitsq +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +!rc include 'COMMON.DEFORM' +! include 'COMMON.IOUNITS' +!el#ifdef UNRES +!el use geometry_data !include 'COMMON.CHAIN' +!el#endif + + real(kind=8),dimension(6*nres) :: x,x1 !(maxvar) (maxvar=6*maxres) + real(kind=8) :: przes(3),obrot(3,3) + integer :: list(max_thread) + logical :: non_conv,modif + real(kind=8) :: enetbss(max_threadss) + real(kind=8) :: coordss(6*nres,max_threadss) + +!!! local variables - el + integer :: n_thr,num_thread_save,icomp,minimize_s_flag,iprint + real(kind=8) :: energyx,energyy,rms_d + integer :: nlist,k,kk,j,i,iresult + real(kind=8) :: enex_jp,roznica + + nlist=0 +#ifdef UNRES + call var_to_geom(nvar,x) + call chainbuild + do k=1,2*nres + do kk=1,3 + cref(kk,k,1)=c(kk,k) + enddo + enddo +#endif +! write(iout,*)'*ene=',energyx + j=0 + enex_jp=-1.0d+99 + do i=1,n_thr + do k=1,nvar + x1(k)=coordss(k,i) + enddo + if (iprint.gt.3) then + write (iout,*) 'Compare_ss, i=',i + write (iout,*) 'New structure Energy:',energyx + write (iout,'(10f8.3)') (rad2deg*x(k),k=1,nvar) + write (iout,*) 'Template structure Energy:',enetbss(i) + write (iout,'(10f8.3)') (rad2deg*x1(k),k=1,nvar) + endif + +#ifdef UNRES + call var_to_geom(nvar,x1) + call chainbuild +!d write(iout,*)'C and CREF' +!d write(iout,'(i5,3f10.5,5x,3f10.5)')(k,(c(j,k),j=1,3), +!d & (cref(j,k),j=1,3),k=1,nres) + call fitsq(roznica,c(1,1),cref(1,1,1),nres,przes,obrot,non_conv) + if (non_conv) then + print *,'Problems in FITSQ!!!' + print *,'X' + print '(10f8.3)',(x(k),k=1,nvar) + print *,'X1' + print '(10f8.3)',(x1(k),k=1,nvar) + print *,'C and CREF' + print '(i5,3f10.5,5x,3f10.5)',(k,(c(j,k),j=1,3),& + (cref(j,k,1),j=1,3),k=1,nres) + endif + roznica=dsqrt(dabs(roznica)) + iresult = 1 + if (roznica.lt.rms_d) iresult = 0 +#else + energyy=enetbss(i) +!el call cmprs(x,x1,roznica,energyx,energyy,iresult) +#endif + if (iprint.gt.1) write(iout,'(i5,f10.6,$)') i,roznica +! print '(i5,f8.3)',i,roznica + if(iresult.eq.0) then + nlist = nlist + 1 + list(nlist)=i + if (iprint.gt.1) write(iout,*) + if(energyx.ge.enetbss(i)) then + if (iprint.gt.1) & + write(iout,*)'s*>> structure rejected - same as nr ',i, & + ' RMS',roznica + minimize_s_flag=0 + icomp=0 + go to 1106 + endif + endif + if(energyx.lt.enetbss(i).and.enex_jp.lt.enetbss(i))then + j=i + enex_jp=enetbss(i) + endif + enddo + if (iprint.gt.1) write(iout,*) + if(nlist.gt.0) then + if (modif) then + if (iprint.gt.1) & + write(iout,'(a,i3,$)')'s*>> structure accepted1 - repl nr ',& + list(1) + else + if (iprint.gt.1) & + write(iout,'(a,i3)') & + 's*>> structure accepted1 - would repl nr ',list(1) + endif + icomp=9 + if (.not. modif) goto 1106 + j=list(1) + enetbss(j)=energyx + do i=1,nvar + coordss(i,j)=x(i) + enddo + do j=2,nlist + if (iprint.gt.1) write(iout,'(i3,$)')list(j) + do kk=list(j)+1,nlist + enetbss(kk-1)=enetbss(kk) + do i=1,nvar + coordss(i,kk-1)=coordss(i,kk) + enddo + enddo + enddo + if (iprint.gt.1) write(iout,*) + go to 1106 + endif + if(n_thr.lt.num_thread_save) then + icomp=1 + if (modif) then + if (iprint.gt.1) & + write(iout,*)'s*>> structure accepted - add with nr ',n_thr+1 + else + if (iprint.gt.1) & + write(iout,*)'s*>> structure accepted - would add with nr ',& + n_thr+1 + goto 1106 + endif + n_thr=n_thr+1 + enetbss(n_thr)=energyx + do i=1,nvar + coordss(i,n_thr)=x(i) + enddo + else + if(j.eq.0) then + if (iprint.gt.1) & + write(iout,*)'s*>> structure rejected - too high energy' + icomp=2 + go to 1106 + end if + icomp=3 + if (modif) then + if (iprint.gt.1) & + write(iout,*)'s*>> structure accepted - repl nr ',j + else + if (iprint.gt.1) & + write(iout,*)'s*>> structure accepted - would repl nr ',j + goto 1106 + endif + enetbss(j)=energyx + do i=1,nvar + coordss(i,j)=x(i) + enddo + end if + +1106 continue + return + end subroutine compare_s1 +!----------------------------------------------------------------------------- +! entmcm.F +!----------------------------------------------------------------------------- + subroutine entmcm + + use energy_data + use geometry_data + use MPI_data, only:WhatsUp,MyID + use compare_data, only: ener + use control_data, only: minim,refstr + use io_base + use regularize_, only:fitsq + use control, only: tcpu,ovrtim + use compare + use minimm, only:minimize +! Does modified entropic sampling in the space of minima. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +#ifdef MPL + use MPI_data !include 'COMMON.INFO' +#endif +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.CONTACTS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.THREAD' +! include 'COMMON.NAMES' + logical :: accepted,not_done,over,error,lprint !,ovrtim + integer :: MoveType,nbond +! integer :: conf_comp + real(kind=8) :: RandOrPert + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + real(kind=8) :: elowest,ehighest,eold + real(kind=8) :: przes(3),obr(3,3) + real(kind=8),dimension(6*nres) :: varold !(maxvar) (maxvar=6*maxres) + logical :: non_conv + real(kind=8),dimension(0:n_ene) :: energia,energia_ave + +!!! local variables -el + integer :: i,ii,kkk,it,j,nacc,nfun,ijunk,indmin,indmax,& + ISWEEP,Kwita,iretcode,indeold,iene,noverlap,& + irep,nstart_grow,inde + real(kind=8) :: facee,conste,ejunk,etot,rms,co,frac,& + deix,dent,sold,scur,runtime +! + +! if(.not.allocated(varsave)) allocate(varsave(maxvar,maxsave)) !(maxvar,maxsave) +!d write (iout,*) 'print_mc=',print_mc + WhatsUp=0 + maxtrial_iter=50 +!--------------------------------------------------------------------------- +! Initialize counters. +!--------------------------------------------------------------------------- +! Total number of generated confs. + ngen=0 +! Total number of moves. In general this won't be equal to the number of +! attempted moves, because we may want to reject some "bad" confs just by +! overlap check. + nmove=0 +! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +! motions. +!el allocate(nbond_move(nres)) !(maxres) + + do i=1,nres + nbond_move(i)=0 + enddo +! Initialize total and accepted number of moves of various kind. + do i=0,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +! Total number of energy evaluations. + neneval=0 + nfun=0 + indminn=-max_ene + indmaxx=max_ene + delte=0.5D0 + facee=1.0D0/(maxacc*delte) + conste=dlog(facee) +! Read entropy from previous simulations. + if (ent_read) then + read (ientin,*) indminn,indmaxx,emin,emax + print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin,& + ' emax=',emax + do i=-max_ene,max_ene + entropy(i)=(emin+i*delte)*betbol + enddo + read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) + indmin=indminn + indmax=indmaxx + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& + ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif ! ent_read +! Read the pool of conformations + call read_pool +!---------------------------------------------------------------------------- +! Entropy-sampling simulations with continually updated entropy +! Loop thru simulations +!---------------------------------------------------------------------------- + DO ISWEEP=1,NSWEEP +!---------------------------------------------------------------------------- +! Take a conformation from the pool +!---------------------------------------------------------------------------- + if (npool.gt.0) then + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + write (iout,*) 'Took conformation',ii,' from the pool energy=',& + epool(ii) + call var_to_geom(nvar,varia) +! Print internal coordinates of the initial conformation + call intout + else + call gen_rand_conf(1,*20) + endif +!---------------------------------------------------------------------------- +! Compute and print initial energies. +!---------------------------------------------------------------------------- + nsave=0 +#ifdef MPL + allocate(nsave_part(nctasks)) + if (MyID.eq.MasterID) then + do i=1,nctasks + nsave_part(i)=0 + enddo + endif +#endif + Kwita=0 + WhatsUp=0 + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + call etotal(energia) + etot = energia(0) + call enerprint(energia) +! Minimize the energy of the first conformation. + if (minim) then + call geom_to_var(nvar,varia) + call minimize(etot,varia,iretcode,nfun) + call etotal(energia) + etot = energia(0) + write (iout,'(/80(1h*)/a/80(1h*))') & + 'Results of the first energy minimization:' + call enerprint(energia) + endif + if (refstr) then + kkk=1 + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk),& + nsup,przes,& + obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order:',co + write (istat,'(i5,11(1pe14.5))') 0,& + (energia(print_order(i)),i=1,nprint_ene),etot,rms,frac,co + else + write (istat,'(i5,9(1pe14.5))') 0,& + (energia(print_order(i)),i=1,nprint_ene),etot + endif + close(istat) + neneval=neneval+nfun+1 + if (.not. ent_read) then +! Initialize the entropy array + do i=-max_ene,max_ene + emin=etot +! Uncomment the line below for actual entropic sampling (start with uniform +! energy distribution). +! entropy(i)=0.0D0 +! Uncomment the line below for multicanonical sampling (start with Boltzmann +! distribution). + entropy(i)=(emin+i*delte)*betbol + enddo + emax=10000000.0D0 + emin=etot + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif ! ent_read +#ifdef MPL + call recv_stop_sig(Kwita) + if (whatsup.eq.1) then + call send_stop_sig(-2) + not_done=.false. + else if (whatsup.le.-2) then + not_done=.false. + else if (whatsup.eq.2) then + not_done=.false. + else + not_done=.true. + endif +#else + not_done = (iretcode.ne.11) +#endif + write (iout,'(/80(1h*)/20x,a/80(1h*))') & + 'Enter Monte Carlo procedure.' + close(igeom) + call briefout(0,etot) + do i=1,nvar + varold(i)=varia(i) + enddo + eold=etot + indeold=(eold-emin)/delte + deix=eold-(emin+indeold*delte) + dent=entropy(indeold+1)-entropy(indeold) +!d write (iout,*) 'indeold=',indeold,' deix=',deix,' dent=',dent +!d write (*,*) 'Processor',MyID,' indeold=',indeold,' deix=',deix, +!d & ' dent=',dent + sold=entropy(indeold)+(dent/delte)*deix + elowest=etot + write (iout,*) 'eold=',eold,' sold=',sold,' elowest=',etot + write (*,*) 'Processor',MyID,' eold=',eold,' sold=',sold,& + ' elowest=',etot + if (minim) call zapis(varia,etot) + nminima(1)=1.0D0 +! NACC is the counter for the accepted conformations of a given processor + nacc=0 +! NACC_TOT counts the total number of accepted conformations + nacc_tot=0 +#ifdef MPL + if (MyID.eq.MasterID) then + call receive_MCM_info + else + call send_MCM_info(2) + endif +#endif + do iene=indminn,indmaxx + nhist(iene)=0.0D0 + enddo + do i=2,maxsave + nminima(i)=0.0D0 + enddo +! Main loop. +!---------------------------------------------------------------------------- + elowest=1.0D10 + ehighest=-1.0D10 + it=0 + do while (not_done) + it=it+1 + if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') & + 'Beginning iteration #',it +! Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + noverlap=0 ! # of overlapping confs. + accepted=.false. + do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) + ntrial=ntrial+1 +! Retrieve the angles of previously accepted conformation + do j=1,nvar + varia(j)=varold(j) + enddo +!d write (iout,'(a)') 'Old variables:' +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + call var_to_geom(nvar,varia) +! Rebuild the chain. + call chainbuild + MoveType=0 + nbond=0 + lprint=.true. +! Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0) & + write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,1.0D0) + if (error) goto 20 + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& + MoveType,' returned from PERTURB.' + goto 20 + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0) & + write (iout,'(2a,i3)') 'Random-generated conformation',& + ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) +!d write (iout,'(a)') 'New variables:' +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + ngen=ngen+1 + if (print_mc.gt.0) write (iout,'(a,i5,a,i10,a,i10)') & + 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + if (print_mc.gt.0) write (*,'(a,i5,a,i10,a,i10)') & + 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + call etotal(energia) + etot = energia(0) +! call enerprint(energia(0)) +! write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest + if (etot-elowest.gt.overlap_cut) then + write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it,& + ' Overlap detected in the current conf.; energy is',etot + neneval=neneval+1 + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,'(a)') 'Too many overlapping confs.' + goto 20 + endif + else + if (minim) then + call minimize(etot,varia,iretcode,nfun) +!d write (iout,'(a)') 'Variables after minimization:' +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + call etotal(energia) + etot = energia(0) + neneval=neneval+nfun+1 + endif + if (print_mc.gt.2) then + write (iout,'(a)') 'Total energies of trial conf:' + call enerprint(energia) + else if (print_mc.eq.1) then + write (iout,'(a,i6,a,1pe16.6)') & + 'Trial conformation:',ngen,' energy:',etot + endif +!-------------------------------------------------------------------------- +!... Acceptance test +!-------------------------------------------------------------------------- + accepted=.false. + if (WhatsUp.eq.0) & + call accepting(etot,eold,scur,sold,varia,varold,& + accepted) + if (accepted) then + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) elowest=etot + if (ehighest.lt.etot) ehighest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +! Check against conformation repetitions. + irep=conf_comp(varia,etot) +#if defined(AIX) || defined(PGI) + open (istat,file=statname,position='append') +#else + open (istat,file=statname,access='append') +#endif + if (refstr) then + kkk=1 + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk),& + nsup,& + przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + if (print_mc.gt.0) & + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order:',co + if (print_stat) & + write (istat,'(i5,11(1pe14.5))') it,& + (energia(print_order(i)),i=1,nprint_ene),etot,& + rms,frac,co + elseif (print_stat) then + write (istat,'(i5,10(1pe14.5))') it,& + (energia(print_order(i)),i=1,nprint_ene),etot + endif + close(istat) + if (print_mc.gt.1) & + call statprint(nacc,nfun,iretcode,etot,elowest) +! Print internal coordinates. + if (print_int) call briefout(nacc,etot) +#ifdef MPL + if (MyID.ne.MasterID) then + call recv_stop_sig(Kwita) +!d print *,'Processor:',MyID,' STOP=',Kwita + if (irep.eq.0) then + call send_MCM_info(2) + else + call send_MCM_info(1) + endif + endif +#endif +! Store the accepted conf. and its energy. + eold=etot + sold=scur + do i=1,nvar + varold(i)=varia(i) + enddo + if (irep.eq.0) then + irep=nsave+1 +!d write (iout,*) 'Accepted conformation:' +!d write (iout,*) (rad2deg*varia(i),i=1,nphi) + if (minim) call zapis(varia,etot) + do i=1,n_ene + ener(i,nsave)=energia(i) + enddo + ener(n_ene+1,nsave)=etot + ener(n_ene+2,nsave)=frac + endif + nminima(irep)=nminima(irep)+1.0D0 +! print *,'irep=',irep,' nminima=',nminima(irep) +#ifdef MPL + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + endif ! accepted + endif ! overlap +#ifdef MPL + if (MyID.eq.MasterID) then + call receive_MCM_info + if (nacc_tot.ge.maxacc) accepted=.true. + endif +#endif + if (ntrial.gt.maxtrial_iter .and. npool.gt.0) then +! Take a conformation from the pool + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + write (iout,*) 'Iteration',it,' max. # of trials exceeded.' + write (iout,*) & + 'Take conformation',ii,' from the pool energy=',epool(ii) + if (print_mc.gt.2) & + write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) + ntrial=0 + endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) + 30 continue + enddo ! accepted +#ifdef MPL + if (MyID.eq.MasterID) then + call receive_MCM_info + endif + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + if (ovrtim()) WhatsUp=-1 +!d write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita + not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) & + .and. (Kwita.eq.0) +!d write (iout,*) 'not_done=',not_done +#ifdef MPL + if (Kwita.lt.0) then + print *,'Processor',MyID,& + ' has received STOP signal =',Kwita,' in EntSamp.' +!d print *,'not_done=',not_done + if (Kwita.lt.-1) WhatsUp=Kwita + else if (nacc_tot.ge.maxacc) then + print *,'Processor',MyID,' calls send_stop_sig,',& + ' because a sufficient # of confs. have been collected.' +!d print *,'not_done=',not_done + call send_stop_sig(-1) + else if (WhatsUp.eq.-1) then + print *,'Processor',MyID,& + ' calls send_stop_sig because of timeout.' +!d print *,'not_done=',not_done + call send_stop_sig(-2) + endif +#endif + enddo ! not_done + +!----------------------------------------------------------------- +!... Construct energy histogram & update entropy +!----------------------------------------------------------------- + go to 21 + 20 WhatsUp=-3 +#ifdef MPL + write (iout,*) 'Processor',MyID,& + ' is broadcasting ERROR-STOP signal.' + write (*,*) 'Processor',MyID,& + ' is broadcasting ERROR-STOP signal.' + call send_stop_sig(-3) +#endif + 21 continue +#ifdef MPL + if (MyID.eq.MasterID) then +! call receive_MCM_results + call receive_energies +#endif + do i=1,nsave + if (esave(i).lt.elowest) elowest=esave(i) + if (esave(i).gt.ehighest) ehighest=esave(i) + enddo + write (iout,'(a,i10)') '# of accepted confs:',nacc_tot + write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest,& + ' Highest energy',ehighest + if (isweep.eq.1 .and. .not.ent_read) then + emin=elowest + emax=ehighest + write (iout,*) 'EMAX=',emax + indminn=0 + indmaxx=(ehighest-emin)/delte + indmin=indminn + indmax=indmaxx + do i=-max_ene,max_ene + entropy(i)=(emin+i*delte)*betbol + enddo + ent_read=.true. + else + indmin=(elowest-emin)/delte + indmax=(ehighest-emin)/delte + if (indmin.lt.indminn) indminn=indmin + if (indmax.gt.indmaxx) indmaxx=indmax + endif + write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx +! Construct energy histogram + do i=1,nsave + inde=(esave(i)-emin)/delte + nhist(inde)=nhist(inde)+nminima(i) + enddo +! Update entropy (density of states) + do i=indmin,indmax + if (nhist(i).gt.0) then + entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) + endif + enddo +!d do i=indmaxx+1 +!d entropy(i)=1.0D+10 +!d enddo + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') & + 'End of macroiteration',isweep + write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest,& + ' Ehighest=',ehighest + write (iout,'(a)') 'Frequecies of minima' + do i=1,nsave + write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) + enddo + write (iout,'(/a)') 'Energy histogram' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,nhist(i) + enddo + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo +!----------------------------------------------------------------- +!... End of energy histogram construction +!----------------------------------------------------------------- +#ifdef MPL + entropy(-max_ene-4)=dfloat(indminn) + entropy(-max_ene-3)=dfloat(indmaxx) + entropy(-max_ene-2)=emin + entropy(-max_ene-1)=emax + call send_MCM_update +!d print *,entname,ientout + open (ientout,file=entname,status='unknown') + write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax + do i=indminn,indmaxx + write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) + enddo + close(ientout) + else + write (iout,'(a)') 'Frequecies of minima' + do i=1,nsave + write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) + enddo +! call send_MCM_results + call send_energies + call receive_MCM_update + indminn=entropy(-max_ene-4) + indmaxx=entropy(-max_ene-3) + emin=entropy(-max_ene-2) + emax=entropy(-max_ene-1) + write (iout,*) 'Received from master:' + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& + ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif + if (WhatsUp.lt.-1) return +#else + if (ovrtim() .or. WhatsUp.lt.0) return +#endif + + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc,nfun,iretcode,etot,elowest) + write (iout,'(a)') & + 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) +!el write (iout,'(a,i10)') 'Number of chain regrowths:',nregrow +!el write (iout,'(a,i10)') 'Accepted chain regrowths:',nregrow_acc + +!--------------------------------------------------------------------------- + ENDDO ! ISWEEP +!--------------------------------------------------------------------------- + + runtime=tcpu() + + if (isweep.eq.nsweep .and. it.ge.maxacc) & + write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + return + end subroutine entmcm +!----------------------------------------------------------------------------- + subroutine accepting(ecur,eold,scur,sold,x,xold,accepted) + + use geometry_data, only: nphi + use energy_data, only: max_ene +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +#ifdef MPL + use MPI_data !include 'COMMON.INFO' +#endif +! include 'COMMON.GEO' + real(kind=8) :: ecur,eold,xx,bol !,ran_number + real(kind=8),dimension(6*nres) :: x,xold !(maxvar) (maxvar=6*maxres) + real(kind=8) :: tole=1.0D-1, tola=5.0D0 + logical :: accepted + +!!! local variables - el + integer :: indecur + real(kind=8) :: scur,sold,xxh,deix,dent + +! Check if the conformation is similar. +!d write (iout,*) 'Enter ACCEPTING' +!d write (iout,*) 'Old PHI angles:' +!d write (iout,*) (rad2deg*xold(i),i=1,nphi) +!d write (iout,*) 'Current angles' +!d write (iout,*) (rad2deg*x(i),i=1,nphi) +!d ddif=dif_ang(nphi,x,xold) +!d write (iout,*) 'Angle norm:',ddif +!d write (iout,*) 'ecur=',ecur,' emax=',emax + if (ecur.gt.emax) then + accepted=.false. + if (print_mc.gt.0) & + write (iout,'(a)') 'Conformation rejected as too high in energy' + return + else if (dabs(ecur-eold).lt.tole .and. & + dif_ang(nphi,x,xold).lt.tola) then + accepted=.false. + if (print_mc.gt.0) & + write (iout,'(a)') 'Conformation rejected as too similar' + return + endif +! Else evaluate the entropy of the conf and compare it with that of the previous +! one. + indecur=(ecur-emin)/delte + if (iabs(indecur).gt.max_ene) then + write (iout,'(a,2i5)') & + 'Accepting: Index out of range:',indecur + scur=1000.0D0 + else if (indecur.eq.indmaxx) then + scur=entropy(indecur) + if (print_mc.gt.0) write (iout,*)'Energy boundary reached',& + indmaxx,indecur,entropy(indecur) + else + deix=ecur-(emin+indecur*delte) + dent=entropy(indecur+1)-entropy(indecur) + scur=entropy(indecur)+(dent/delte)*deix + endif +!d print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, +!d & ' scur=',scur,' eold=',eold,' sold=',sold +!d print *,'deix=',deix,' dent=',dent,' delte=',delte + if (print_mc.gt.1) then + write(iout,*)'ecur=',ecur,' indecur=',indecur,' scur=',scur + write(iout,*)'eold=',eold,' sold=',sold + endif + if (scur.le.sold) then + accepted=.true. + else +! Else carry out acceptance test + xx=ran_number(0.0D0,1.0D0) + xxh=scur-sold + if (xxh.gt.50.0D0) then + bol=0.0D0 + else + bol=exp(-xxh) + endif + if (bol.gt.xx) then + accepted=.true. + if (print_mc.gt.0) write (iout,'(a)') & + 'Conformation accepted.' + else + accepted=.false. + if (print_mc.gt.0) write (iout,'(a)') & + 'Conformation rejected.' + endif + endif + return + end subroutine accepting +!----------------------------------------------------------------------------- + subroutine read_pool + + use io_base, only:read_angles +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.VAR' + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + +!!! local variables - el + integer :: j,i,iconf + + print '(a)','Call READ_POOL' + do npool=1,max_pool + print *,'i=',i + read (intin,'(i5,f10.5)',end=10,err=10) iconf,epool(npool) + if (epool(npool).eq.0.0D0) goto 10 + call read_angles(intin,*10) + call geom_to_var(nvar,xpool(1,npool)) + enddo + goto 11 + 10 npool=npool-1 + 11 write (iout,'(a,i5)') 'Number of pool conformations:',npool + if (print_mc.gt.2) then + do i=1,npool + write (iout,'(a,i5,a,1pe14.5)') 'Pool conformation',i,' energy',& + epool(i) + write (iout,'(10f8.3)') (rad2deg*xpool(j,i),j=1,nvar) + enddo + endif ! (print_mc.gt.2) + return + end subroutine read_pool +!----------------------------------------------------------------------------- +! mc.F +!----------------------------------------------------------------------------- + subroutine monte_carlo + + use energy_data + use geometry_data + use MPI_data, only:ifinish,nctasks,WhatsUp,MyID + use control_data, only:refstr,MaxProcs + use io_base + use control, only:tcpu,ovrtim + use regularize_, only:fitsq + use compare +! use control +! Does Boltzmann and entropic sampling without energy minimization +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +#ifdef MPL + use MPI_data !include 'COMMON.INFO' +#endif +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.CONTACTS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.THREAD' +! include 'COMMON.NAMES' + logical :: accepted,not_done,over,error,lprint !,ovrtim + integer :: MoveType,nbond,nbins +! integer :: conf_comp + real(kind=8) :: RandOrPert + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + real(kind=8) :: elowest,elowest1,ehighest,ehighest1,eold + real(kind=8) :: przes(3),obr(3,3) + real(kind=8),dimension(6*nres) :: varold !(maxvar) (maxvar=6*maxres) + logical :: non_conv + integer,dimension(-1:MaxMoveType+1,0:MaxProcs-1) :: moves1,moves_acc1 !(-1:MaxMoveType+1,0:MaxProcs-1) +#ifdef MPL + real(kind=8) :: etot_temp,etot_all(0:MaxProcs) + external d_vadd,d_vmin,d_vmax + real(kind=8),dimension(-max_ene:max_ene) :: entropy1,nhist1 + integer,dimension(nres*(MaxProcs+1)) :: nbond_move1,nbond_acc1 + integer,dimension(2) :: itemp +#endif + real(kind=8),dimension(6*nres) :: var_lowest !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(0:n_ene) :: energia,energia_ave +! +!!! local variables - el + integer :: i,j,it,ii,iproc,nacc,ISWEEP,nfun,indmax,indmin,ijunk,& + Kwita,indeold,imdmax,inde,iretcode,nstart_grow,noverlap + real(kind=8) :: facee,conste,ejunk,etot,sold,frac,runtime,& + frac_ave,rms_ave,etot_ave,scur,from_pool,co,rms + + write(iout,'(a,i8,2x,a,f10.5)') & + 'pool_read_freq=',pool_read_freq,' pool_fraction=',pool_fraction + open (istat,file=statname) + WhatsUp=0 + indminn=-max_ene + indmaxx=max_ene + facee=1.0D0/(maxacc*delte) +! Number of bins in energy histogram + nbins=e_up/delte-1 + write (iout,*) 'NBINS=',nbins + conste=dlog(facee) +! Read entropy from previous simulations. + if (ent_read) then + read (ientin,*) indminn,indmaxx,emin,emax + print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin,& + ' emax=',emax + do i=-max_ene,max_ene + entropy(i)=0.0D0 + enddo + read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) + indmin=indminn + indmax=indmaxx + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& + ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif ! ent_read +! Read the pool of conformations + call read_pool + elowest=1.0D+10 + ehighest=-1.0D+10 +!---------------------------------------------------------------------------- +! Entropy-sampling simulations with continually updated entropy; +! set NSWEEP=1 for Boltzmann sampling. +! Loop thru simulations +!---------------------------------------------------------------------------- + allocate(ifinish(nctasks)) + DO ISWEEP=1,NSWEEP +! +! Initialize the IFINISH array. +! +#ifdef MPL + do i=1,nctasks + ifinish(i)=0 + enddo +#endif +!--------------------------------------------------------------------------- +! Initialize counters. +!--------------------------------------------------------------------------- +! Total number of generated confs. + ngen=0 +! Total number of moves. In general this won't be equal to the number of +! attempted moves, because we may want to reject some "bad" confs just by +! overlap check. + nmove=0 +! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +! motions. +!el allocate(nbond_move(nres)) !(maxres) +!el allocate(nbond_acc(nres)) !(maxres) + + do i=1,nres + nbond_move(i)=0 + nbond_acc(i)=0 + enddo +! Initialize total and accepted number of moves of various kind. + do i=-1,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +! Total number of energy evaluations. + neneval=0 + nfun=0 +!---------------------------------------------------------------------------- +! Take a conformation from the pool +!---------------------------------------------------------------------------- + rewind(istat) + write (iout,*) 'emin=',emin,' emax=',emax + if (npool.gt.0) then + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + write (iout,*) 'Took conformation',ii,' from the pool energy=',& + epool(ii) + call var_to_geom(nvar,varia) +! Print internal coordinates of the initial conformation + call intout + else if (isweep.gt.1) then + if (eold.lt.emax) then + do i=1,nvar + varia(i)=varold(i) + enddo + else + do i=1,nvar + varia(i)=var_lowest(i) + enddo + endif + call var_to_geom(nvar,varia) + endif +!---------------------------------------------------------------------------- +! Compute and print initial energies. +!---------------------------------------------------------------------------- + nsave=0 + Kwita=0 + WhatsUp=0 + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + call geom_to_var(nvar,varia) + call etotal(energia) + etot = energia(0) + call enerprint(energia) + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),nsup,przes,& + obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order',co + write (istat,'(i10,16(1pe14.5))') 0,& + (energia(print_order(i)),i=1,nprint_ene),& + etot,rms,frac,co + else + write (istat,'(i10,14(1pe14.5))') 0,& + (energia(print_order(i)),i=1,nprint_ene),etot + endif +! close(istat) + neneval=neneval+1 + if (.not. ent_read) then +! Initialize the entropy array +#ifdef MPL +! Collect total energies from other processors. + etot_temp=etot + etot_all(0)=etot + call mp_gather(etot_temp,etot_all,8,MasterID,cgGroupID) + if (MyID.eq.MasterID) then +! Get the lowest and the highest energy. + print *,'MASTER: etot_temp: ',(etot_all(i),i=0,nprocs-1),& + ' emin=',emin,' emax=',emax + emin=1.0D10 + emax=-1.0D10 + do i=0,nprocs + if (emin.gt.etot_all(i)) emin=etot_all(i) + if (emax.lt.etot_all(i)) emax=etot_all(i) + enddo + emax=emin+e_up + endif ! MyID.eq.MasterID + etot_all(1)=emin + etot_all(2)=emax + print *,'Processor',MyID,' calls MP_BCAST to send/recv etot_all' + call mp_bcast(etot_all(1),16,MasterID,cgGroupID) + print *,'Processor',MyID,' MP_BCAST to send/recv etot_all ended' + if (MyID.ne.MasterID) then + print *,'Processor:',MyID,etot_all(1),etot_all(2),& + etot_all(1),etot_all(2) + emin=etot_all(1) + emax=etot_all(2) + endif ! MyID.ne.MasterID + write (iout,*) 'After MP_GATHER etot_temp=',& + etot_temp,' emin=',emin +#else + emin=etot + emax=emin+e_up + indminn=0 + indmin=0 +#endif + IF (MULTICAN) THEN +! Multicanonical sampling - start from Boltzmann distribution + do i=-max_ene,max_ene + entropy(i)=(emin+i*delte)*betbol + enddo + ELSE +! Entropic sampling - start from uniform distribution of the density of states + do i=-max_ene,max_ene + entropy(i)=0.0D0 + enddo + ENDIF ! MULTICAN + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + if (isweep.eq.1) then + emax=emin+e_up + indminn=0 + indmin=0 + indmaxx=indminn+nbins + indmax=indmaxx + endif ! isweep.eq.1 + endif ! .not. ent_read +#ifdef MPL + call recv_stop_sig(Kwita) + if (whatsup.eq.1) then + call send_stop_sig(-2) + not_done=.false. + else if (whatsup.le.-2) then + not_done=.false. + else if (whatsup.eq.2) then + not_done=.false. + else + not_done=.true. + endif +#else + not_done=.true. +#endif + write (iout,'(/80(1h*)/20x,a/80(1h*))') & + 'Enter Monte Carlo procedure.' + close(igeom) + call briefout(0,etot) + do i=1,nvar + varold(i)=varia(i) + enddo + eold=etot + call entropia(eold,sold,indeold) +! NACC is the counter for the accepted conformations of a given processor + nacc=0 +! NACC_TOT counts the total number of accepted conformations + nacc_tot=0 +! Main loop. +!---------------------------------------------------------------------------- +! Zero out average energies + do i=0,n_ene + energia_ave(i)=0.0d0 + enddo +! Initialize energy histogram + do i=-max_ene,max_ene + nhist(i)=0.0D0 + enddo ! i +! Zero out iteration counter. + it=0 + do j=1,nvar + varold(j)=varia(j) + enddo +! Begin MC iteration loop. + do while (not_done) + it=it+1 +! Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + noverlap=0 ! # of overlapping confs. + accepted=.false. + do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) + ntrial=ntrial+1 +! Retrieve the angles of previously accepted conformation + do j=1,nvar + varia(j)=varold(j) + enddo + call var_to_geom(nvar,varia) +! Rebuild the chain. + call chainbuild + MoveType=0 + nbond=0 + lprint=.true. +! Decide whether to take a conformation from the pool or generate/perturb one +! randomly + from_pool=ran_number(0.0D0,1.0D0) + if (npool.gt.0 .and. from_pool.lt.pool_fraction) then +! Throw a dice to choose the conformation from the pool + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + call var_to_geom(nvar,varia) + call chainbuild +!d call intout +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a,i3,a,f10.5)') & + 'Try conformation',ii,' from the pool energy=',epool(ii) + MoveType=-1 + moves(-1)=moves(-1)+1 + else +! Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,0.1D0) + if (error) goto 20 + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& + MoveType,' returned from PERTURB.' + goto 20 + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(2a,i3)') 'Random-generated conformation',& + ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) + endif ! pool +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + ngen=ngen+1 + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a,i5,a,i10,a,i10)') & + 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (*,'(a,i5,a,i10,a,i10)') & + 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + call etotal(energia) + etot = energia(0) + neneval=neneval+1 +!d call enerprint(energia(0)) +!d write(iout,*)'it=',it,' etot=',etot + if (etot-elowest.gt.overlap_cut) then + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it,& + ' Overlap detected in the current conf.; energy is',etot + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,'(a)') 'Too many overlapping confs.' + goto 20 + endif + else +!-------------------------------------------------------------------------- +!... Acceptance test +!-------------------------------------------------------------------------- + accepted=.false. + if (WhatsUp.eq.0) & + call accept_mc(it,etot,eold,scur,sold,varia,varold,accepted) + if (accepted) then + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) then + elowest=etot + do i=1,nvar + var_lowest(i)=varia(i) + enddo + endif + if (ehighest.lt.etot) ehighest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +! Compare with reference structure. + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),& + nsup,przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + endif ! refstr +! +! Periodically save average energies and confs. +! + do i=0,n_ene + energia_ave(i)=energia_ave(i)+energia(i) + enddo + moves(MaxMoveType+1)=nmove + moves_acc(MaxMoveType+1)=nacc + IF ((it/save_frequency)*save_frequency.eq.it) THEN + do i=0,n_ene + energia_ave(i)=energia_ave(i)/save_frequency + enddo + etot_ave=energia_ave(0) +!#ifdef AIX +! open (istat,file=statname,position='append') +!#else +! open (istat,file=statname,access='append') +!endif + if (print_mc.gt.0) & + write (iout,'(80(1h*)/20x,a,i20)') & + 'Iteration #',it + if (refstr .and. print_mc.gt.0) then + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order:',co + endif + if (print_stat) then + if (refstr) then + write (istat,'(i10,10(1pe14.5))') it,& + (energia_ave(print_order(i)),i=1,nprint_ene),& + etot_ave,rms_ave,frac_ave + else + write (istat,'(i10,10(1pe14.5))') it,& + (energia_ave(print_order(i)),i=1,nprint_ene),& + etot_ave + endif + endif +! close(istat) + if (print_mc.gt.0) & + call statprint(nacc,nfun,iretcode,etot,elowest) +! Print internal coordinates. + if (print_int) call briefout(nacc,etot) + do i=0,n_ene + energia_ave(i)=0.0d0 + enddo + ENDIF ! ( (it/save_frequency)*save_frequency.eq.it) +! Update histogram + inde=icialosc((etot-emin)/delte) + nhist(inde)=nhist(inde)+1.0D0 +#ifdef MPL + if ( (it/message_frequency)*message_frequency.eq.it & + .and. (MyID.ne.MasterID) ) then + call recv_stop_sig(Kwita) + call send_MCM_info(message_frequency) + endif +#endif +! Store the accepted conf. and its energy. + eold=etot + sold=scur + do i=1,nvar + varold(i)=varia(i) + enddo +#ifdef MPL + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + endif ! accepted + endif ! overlap +#ifdef MPL + if (MyID.eq.MasterID .and. & + (it/message_frequency)*message_frequency.eq.it) then + call receive_MC_info + if (nacc_tot.ge.maxacc) accepted=.true. + endif +#endif +! if ((ntrial.gt.maxtrial_iter +! & .or. (it/pool_read_freq)*pool_read_freq.eq.it) +! & .and. npool.gt.0) then +! Take a conformation from the pool +! ii=iran_num(1,npool) +! do i=1,nvar +! varold(i)=xpool(i,ii) +! enddo +! if (ntrial.gt.maxtrial_iter) +! & write (iout,*) 'Iteration',it,' max. # of trials exceeded.' +! write (iout,*) +! & 'Take conformation',ii,' from the pool energy=',epool(ii) +! if (print_mc.gt.2) +! & write (iout,'(10f8.3)') (rad2deg*varold(i),i=1,nvar) +! ntrial=0 +! eold=epool(ii) +! call entropia(eold,sold,indeold) +! accepted=.true. +! endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) + 30 continue + enddo ! accepted +#ifdef MPL + if (MyID.eq.MasterID .and. & + (it/message_frequency)*message_frequency.eq.it) then + call receive_MC_info + endif + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + if (ovrtim()) WhatsUp=-1 +!d write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita + not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) & + .and. (Kwita.eq.0) +!d write (iout,*) 'not_done=',not_done +#ifdef MPL + if (Kwita.lt.0) then + print *,'Processor',MyID,& + ' has received STOP signal =',Kwita,' in EntSamp.' +!d print *,'not_done=',not_done + if (Kwita.lt.-1) WhatsUp=Kwita + if (MyID.ne.MasterID) call send_MCM_info(-1) + else if (nacc_tot.ge.maxacc) then + print *,'Processor',MyID,' calls send_stop_sig,',& + ' because a sufficient # of confs. have been collected.' +!d print *,'not_done=',not_done + call send_stop_sig(-1) + if (MyID.ne.MasterID) call send_MCM_info(-1) + else if (WhatsUp.eq.-1) then + print *,'Processor',MyID,& + ' calls send_stop_sig because of timeout.' +!d print *,'not_done=',not_done + call send_stop_sig(-2) + if (MyID.ne.MasterID) call send_MCM_info(-1) + endif +#endif + enddo ! not_done + +!----------------------------------------------------------------- +!... Construct energy histogram & update entropy +!----------------------------------------------------------------- + go to 21 + 20 WhatsUp=-3 +#ifdef MPL + write (iout,*) 'Processor',MyID,& + ' is broadcasting ERROR-STOP signal.' + write (*,*) 'Processor',MyID,& + ' is broadcasting ERROR-STOP signal.' + call send_stop_sig(-3) + if (MyID.ne.MasterID) call send_MCM_info(-1) +#endif + 21 continue + write (iout,'(/a)') 'Energy histogram' + do i=-100,100 + write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) + enddo +#ifdef MPL +! Wait until every processor has sent complete MC info. + if (MyID.eq.MasterID) then + not_done=.true. + do while (not_done) +! write (*,*) 'The IFINISH array:' +! write (*,*) (ifinish(i),i=1,nctasks) + not_done=.false. + do i=2,nctasks + not_done=not_done.or.(ifinish(i).ge.0) + enddo + if (not_done) call receive_MC_info + enddo + endif +! Make collective histogram from the work of all processors. + msglen=(2*max_ene+1)*8 + print *,& + 'Processor',MyID,' calls MP_REDUCE to send/receive histograms',& + ' msglen=',msglen + call mp_reduce(nhist,nhist1,msglen,MasterID,d_vadd,& + cgGroupID) + print *,'Processor',MyID,' MP_REDUCE accomplished for histogr.' + do i=-max_ene,max_ene + nhist(i)=nhist1(i) + enddo +! Collect min. and max. energy + print *, & + 'Processor',MyID,' calls MP_REDUCE to send/receive energy borders' + call mp_reduce(elowest,elowest1,8,MasterID,d_vmin,cgGroupID) + call mp_reduce(ehighest,ehighest1,8,MasterID,d_vmax,cgGroupID) + print *,'Processor',MyID,' MP_REDUCE accomplished for energies.' + IF (MyID.eq.MasterID) THEN + elowest=elowest1 + ehighest=ehighest1 +#endif + write (iout,'(a,i10)') '# of accepted confs:',nacc_tot + write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest,& + ' Highest energy',ehighest + indmin=icialosc((elowest-emin)/delte) + imdmax=icialosc((ehighest-emin)/delte) + if (indmin.lt.indminn) then + emax=emin+indmin*delte+e_up + indmaxx=indmin+nbins + indminn=indmin + endif + if (.not.ent_read) ent_read=.true. + write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx +! Update entropy (density of states) + do i=indmin,indmax + if (nhist(i).gt.0) then + entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) + endif + enddo + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') & + 'End of macroiteration',isweep + write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest,& + ' Ehighest=',ehighest + write (iout,'(/a)') 'Energy histogram' + do i=indminn,indmaxx + write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) + enddo + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f20.5)') i,emin+i*delte,entropy(i) + enddo +!----------------------------------------------------------------- +!... End of energy histogram construction +!----------------------------------------------------------------- +#ifdef MPL + ELSE + if (.not. ent_read) ent_read=.true. + ENDIF ! MyID .eq. MaterID + if (MyID.eq.MasterID) then + itemp(1)=indminn + itemp(2)=indmaxx + endif + print *,'before mp_bcast processor',MyID,' indminn=',indminn,& + ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) + call mp_bcast(itemp(1),8,MasterID,cgGroupID) + call mp_bcast(emax,8,MasterID,cgGroupID) + print *,'after mp_bcast processor',MyID,' indminn=',indminn,& + ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) + if (MyID .ne. MasterID) then + indminn=itemp(1) + indmaxx=itemp(2) + endif + msglen=(indmaxx-indminn+1)*8 + print *,'processor',MyID,' calling mp_bcast msglen=',msglen,& + ' indminn=',indminn,' indmaxx=',indmaxx,' isweep=',isweep + call mp_bcast(entropy(indminn),msglen,MasterID,cgGroupID) + IF(MyID.eq.MasterID .and. .not. ovrtim() .and. WhatsUp.ge.0)THEN + open (ientout,file=entname,status='unknown') + write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax + do i=indminn,indmaxx + write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) + enddo + close(ientout) + ELSE + write (iout,*) 'Received from master:' + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& + ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + ENDIF ! MyID.eq.MasterID + print *,'Processor',MyID,' calls MP_GATHER' + call mp_gather(nbond_move,nbond_move1,4*Nbm,MasterID,& + cgGroupID) + call mp_gather(nbond_acc,nbond_acc1,4*Nbm,MasterID,& + cgGroupID) + print *,'Processor',MyID,' MP_GATHER call accomplished' + if (MyID.eq.MasterID) then + + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc_tot,nfun,iretcode,etot,elowest) + write (iout,'(a)') & + 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) + + write (iout,'(a)') & + 'Statistics of multi-bond moves of respective processors:' + do iproc=1,Nprocs-1 + do i=1,Nbm + ind=iproc*nbm+i + nbond_move(i)=nbond_move(i)+nbond_move1(ind) + nbond_acc(i)=nbond_acc(i)+nbond_acc1(ind) + enddo + enddo + do iproc=0,NProcs-1 + write (iout,*) 'Processor',iproc,' nbond_move:', & + (nbond_move1(iproc*nbm+i),i=1,Nbm),& + ' nbond_acc:',(nbond_acc1(iproc*nbm+i),i=1,Nbm) + enddo + endif + call mp_gather(moves,moves1,4*(MaxMoveType+3),MasterID,& + cgGroupID) + call mp_gather(moves_acc,moves_acc1,4*(MaxMoveType+3),& + MasterID,cgGroupID) + if (MyID.eq.MasterID) then + do iproc=1,Nprocs-1 + do i=-1,MaxMoveType+1 + moves(i)=moves(i)+moves1(i,iproc) + moves_acc(i)=moves_acc(i)+moves_acc1(i,iproc) + enddo + enddo + nmove=0 + do i=0,MaxMoveType+1 + nmove=nmove+moves(i) + enddo + do iproc=0,NProcs-1 + write (iout,*) 'Processor',iproc,' moves',& + (moves1(i,iproc),i=0,MaxMoveType+1),& + ' moves_acc:',(moves_acc1(i,iproc),i=0,MaxMoveType+1) + enddo + endif +#else + open (ientout,file=entname,status='unknown') + write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax + do i=indminn,indmaxx + write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) + enddo + close(ientout) +#endif + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc_tot,nfun,iretcode,etot,elowest) + write (iout,'(a)') & + 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) + if (ovrtim() .or. WhatsUp.lt.0) return + +!--------------------------------------------------------------------------- + ENDDO ! ISWEEP +!--------------------------------------------------------------------------- + + runtime=tcpu() + + if (isweep.eq.nsweep .and. it.ge.maxacc) & + write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + return + end subroutine monte_carlo +!----------------------------------------------------------------------------- + subroutine accept_mc(it,ecur,eold,scur,sold,x,xold,accepted) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +#ifdef MPL + use MPI_data !include 'COMMON.INFO' +#endif +! include 'COMMON.GEO' + real(kind=8) :: ecur,eold,xx,bol + real(kind=8),dimension(6*nres) :: x,xold !(maxvar) (maxvar=6*maxres) + logical :: accepted + +!el local variables + integer :: it,indecur + real(kind=8) :: scur,sold,xxh +! Check if the conformation is similar. +!d write (iout,*) 'Enter ACCEPTING' +!d write (iout,*) 'Old PHI angles:' +!d write (iout,*) (rad2deg*xold(i),i=1,nphi) +!d write (iout,*) 'Current angles' +!d write (iout,*) (rad2deg*x(i),i=1,nphi) +!d ddif=dif_ang(nphi,x,xold) +!d write (iout,*) 'Angle norm:',ddif +!d write (iout,*) 'ecur=',ecur,' emax=',emax + if (ecur.gt.emax) then + accepted=.false. + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a)') 'Conformation rejected as too high in energy' + return + endif +! Else evaluate the entropy of the conf and compare it with that of the previous +! one. + call entropia(ecur,scur,indecur) +!d print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, +!d & ' scur=',scur,' eold=',eold,' sold=',sold +!d print *,'deix=',deix,' dent=',dent,' delte=',delte + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) then + write(iout,*)'it=',it,'ecur=',ecur,' indecur=',indecur,& + ' scur=',scur + write(iout,*)'eold=',eold,' sold=',sold + endif + if (scur.le.sold) then + accepted=.true. + else +! Else carry out acceptance test + xx=ran_number(0.0D0,1.0D0) + xxh=scur-sold + if (xxh.gt.50.0D0) then + bol=0.0D0 + else + bol=exp(-xxh) + endif + if (bol.gt.xx) then + accepted=.true. + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a)') 'Conformation accepted.' + else + accepted=.false. + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & + write (iout,'(a)') 'Conformation rejected.' + endif + endif + return + end subroutine accept_mc +!----------------------------------------------------------------------------- + integer function icialosc(x) + + real(kind=8) :: x + if (x.lt.0.0D0) then + icialosc=dint(x)-1 + else + icialosc=dint(x) + endif + return + end function icialosc +!----------------------------------------------------------------------------- + subroutine entropia(ecur,scur,indecur) + + use energy_data, only: max_ene +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.IOUNITS' + real(kind=8) :: ecur,scur,deix,dent + integer :: indecur,it !???el + + indecur=icialosc((ecur-emin)/delte) + if (iabs(indecur).gt.max_ene) then + if ((it/print_freq)*it.eq.it) write (iout,'(a,2i5)') & + 'Accepting: Index out of range:',indecur + scur=1000.0D0 + else if (indecur.ge.indmaxx) then + scur=entropy(indecur) + if (print_mc.gt.0 .and. (it/print_freq)*it.eq.it) & + write (iout,*)'Energy boundary reached',& + indmaxx,indecur,entropy(indecur) + else + deix=ecur-(emin+indecur*delte) + dent=entropy(indecur+1)-entropy(indecur) + scur=entropy(indecur)+(dent/delte)*deix + endif + return + end subroutine entropia +!----------------------------------------------------------------------------- +! mcm.F +!----------------------------------------------------------------------------- + subroutine mcm_setup + + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.MCM' +! include 'COMMON.CONTROL' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! +!!! local variables - el + integer :: i,i1,i2,it1,it2,ngly,mmm,maxwinlen + +! Set up variables used in MC/MCM. +! +! allocate(sumpro_bond(0:nres)) !(0:maxres) + + write (iout,'(80(1h*)/20x,a/80(1h*))') 'MCM control parameters:' + write (iout,'(5(a,i7))') 'Maxacc:',maxacc,' MaxTrial:',MaxTrial,& + ' MaxRepm:',MaxRepm,' MaxGen:',MaxGen,' MaxOverlap:',MaxOverlap + write (iout,'(4(a,f8.1)/2(a,i3))') & + 'Tmin:',Tmin,' Tmax:',Tmax,' TstepH:',TstepH,& + ' TstepC:',TstepC,'NstepH:',NstepH,' NstepC:',NstepC + if (nwindow.gt.0) then + write (iout,'(a)') 'Perturbation windows:' + do i=1,nwindow + i1=winstart(i) + i2=winend(i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(a,i3,a,i3,a,i3)') restyp(it1),i1,restyp(it2),i2,& + ' length',winlen(i) + enddo + endif +! Rbolt=8.3143D-3*2.388459D-01 kcal/(mol*K) + RBol=1.9858D-3 +! Number of "end bonds". + koniecl=0 +! koniecl=nphi + print *,'koniecl=',koniecl + write (iout,'(a)') 'Probabilities of move types:' + write (*,'(a)') 'Probabilities of move types:' + do i=1,MaxMoveType + write (iout,'(a,f10.5)') MovTypID(i),& + sumpro_type(i)-sumpro_type(i-1) + write (*,'(a,f10.5)') MovTypID(i),& + sumpro_type(i)-sumpro_type(i-1) + enddo + write (iout,*) +! Maximum length of N-bond segment to be moved +! nbm=nres-1-(2*koniecl-1) + if (nwindow.gt.0) then + maxwinlen=winlen(1) + do i=2,nwindow + if (winlen(i).gt.maxwinlen) maxwinlen=winlen(i) + enddo + nbm=min0(maxwinlen,6) + write (iout,'(a,i3,a,i3)') 'Nbm=',Nbm,' Maxwinlen=',Maxwinlen + else + nbm=min0(6,nres-2) + endif + sumpro_bond(0)=0.0D0 + sumpro_bond(1)=0.0D0 + do i=2,nbm + sumpro_bond(i)=sumpro_bond(i-1)+1.0D0/dfloat(i) + enddo + write (iout,'(a)') 'The SumPro_Bond array:' + write (iout,'(8f10.5)') (sumpro_bond(i),i=1,nbm) + write (*,'(a)') 'The SumPro_Bond array:' + write (*,'(8f10.5)') (sumpro_bond(i),i=1,nbm) +! Maximum number of side chains moved simultaneously +! print *,'nnt=',nnt,' nct=',nct + ngly=0 + do i=nnt,nct + if (itype(i).eq.10) ngly=ngly+1 + enddo + mmm=nct-nnt-ngly+1 + if (mmm.gt.0) then + MaxSideMove=min0((nct-nnt+1)/2,mmm) + endif +! print *,'MaxSideMove=',MaxSideMove +! Max. number of generated confs (not used at present). + maxgen=10000 +! Set initial temperature + Tcur=Tmin + betbol=1.0D0/(Rbol*Tcur) + write (iout,'(a,f8.1,a,f10.5)') 'Initial temperature:',Tcur,& + ' BetBol:',betbol + write (iout,*) 'RanFract=',ranfract + return + end subroutine mcm_setup +!----------------------------------------------------------------------------- +#ifndef MPI + subroutine do_mcm(i_orig) + + use geometry_data + use energy_data + use MPI_data, only:Whatsup + use control_data, only:refstr,minim,iprint + use io_base + use control, only:tcpu,ovrtim + use regularize_, only:fitsq + use compare + use minimm, only:minimize +! Monte-Carlo-with-Minimization calculations - serial code. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.MCM' +! include 'COMMON.CONTACTS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.CACHE' +!rc include 'COMMON.DEFORM' +!rc include 'COMMON.DEFORM1' +! include 'COMMON.NAMES' + logical :: accepted,over,error,lprint,not_done,my_conf,& + enelower,non_conv !,ovrtim + integer :: MoveType,nbond !,conf_comp + integer,dimension(max_cache) :: ifeed + real(kind=8),dimension(6*nres) :: varia,varold !(maxvar) (maxvar=6*maxres) + real(kind=8) :: elowest,eold + real(kind=8) :: przes(3),obr(3,3) + real(kind=8) :: energia(0:n_ene) + real(kind=8) :: coord1(6*nres,max_thread2),enetb1(max_threadss) !el +!!! local variables - el + integer :: i,nf,nacc,it,nout,j,i_orig,nfun,Kwita,iretcode,& + noverlap,nstart_grow,irepet,n_thr,ii + real(kind=8) :: etot,frac,rms,co,RandOrPert,& + rms_deform,runtime +!--------------------------------------------------------------------------- +! Initialize counters. +!--------------------------------------------------------------------------- +! Total number of generated confs. + ngen=0 +! Total number of moves. In general this won't be equal to the number of +! attempted moves, because we may want to reject some "bad" confs just by +! overlap check. + nmove=0 +! Total number of temperature jumps. + ntherm=0 +! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +! motions. +! if(.not.allocated(varsave)) allocate(varsave(maxvar,maxsave)) !(maxvar,maxsave) +! allocate(nbond_move(nres)) !(maxres) + + ncache=0 + do i=1,nres + nbond_move(i)=0 + enddo +! Initialize total and accepted number of moves of various kind. + do i=0,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +! Total number of energy evaluations. + neneval=0 + nfun=0 + nsave=0 + + write (iout,*) 'RanFract=',RanFract + + WhatsUp=0 + Kwita=0 + +!---------------------------------------------------------------------------- +! Compute and print initial energies. +!---------------------------------------------------------------------------- + call intout + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + nf=0 + + call etotal(energia) + etot = energia(0) +! Minimize the energy of the first conformation. + if (minim) then + call geom_to_var(nvar,varia) +! write (iout,*) 'The VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + call minimize(etot,varia,iretcode,nfun) + call var_to_geom(nvar,varia) + call chainbuild + write (iout,*) 'etot from MINIMIZE:',etot +! write (iout,*) 'Tha VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + + call etotal(energia) + etot=energia(0) + call enerprint(energia) + endif + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),nsup,przes,& !el cref(1,nstart_sup) + obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order:',co + if (print_stat) & + write (istat,'(i5,17(1pe14.5))') 0,& + (energia(print_order(i)),i=1,nprint_ene),& + etot,rms,frac,co + else + if (print_stat) write (istat,'(i5,16(1pe14.5))') 0,& + (energia(print_order(i)),i=1,nprint_ene),etot + endif + if (print_stat) close(istat) + neneval=neneval+nfun+1 + write (iout,'(/80(1h*)/20x,a/80(1h*))') & + 'Enter Monte Carlo procedure.' + if (print_int) then + close(igeom) + call briefout(0,etot) + endif + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + elowest=etot + call zapis(varia,etot) + nacc=0 ! total # of accepted confs of the current processor. + nacc_tot=0 ! total # of accepted confs of all processors. + + not_done = (iretcode.ne.11) + +!---------------------------------------------------------------------------- +! Main loop. +!---------------------------------------------------------------------------- + it=0 + nout=0 + do while (not_done) + it=it+1 + write (iout,'(80(1h*)/20x,a,i7)') & + 'Beginning iteration #',it +! Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + accepted=.false. + do while (.not. accepted) + +! Retrieve the angles of previously accepted conformation + noverlap=0 ! # of overlapping confs. + do j=1,nvar + varia(j)=varold(j) + enddo + call var_to_geom(nvar,varia) +! Rebuild the chain. + call chainbuild +! Heat up the system, if necessary. + call heat(over) +! If temperature cannot be further increased, stop. + if (over) goto 20 + MoveType=0 + nbond=0 + lprint=.true. +!d write (iout,'(a)') 'Old variables:' +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) +! Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0) & + write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,1.0D0) + if (error) goto 20 + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& + MoveType,' returned from PERTURB.' + goto 20 + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0) & + write (iout,'(2a,i3)') 'Random-generated conformation',& + ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) +!d write (iout,'(a)') 'New variables:' +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + ngen=ngen+1 + + call etotal(energia) + etot=energia(0) +! call enerprint(energia(0)) +! write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest + if (etot-elowest.gt.overlap_cut) then + if(iprint.gt.1.or.etot.lt.1d20) & + write (iout,'(a,1pe14.5)') & + 'Overlap detected in the current conf.; energy is',etot + neneval=neneval+1 + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,'(a)') 'Too many overlapping confs.' + goto 20 + endif + else + if (minim) then + call minimize(etot,varia,iretcode,nfun) +!d write (iout,*) 'etot from MINIMIZE:',etot +!d write (iout,'(a)') 'Variables after minimization:' +!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + + call etotal(energia) + etot = energia(0) + neneval=neneval+nfun+2 + endif +! call enerprint(energia(0)) + write (iout,'(a,i6,a,1pe16.6)') 'Conformation:',ngen,& + ' energy:',etot +!-------------------------------------------------------------------------- +!... Do Metropolis test +!-------------------------------------------------------------------------- + accepted=.false. + my_conf=.false. + + if (WhatsUp.eq.0 .and. Kwita.eq.0) then + call metropolis(nvar,varia,varold,etot,eold,accepted,& + my_conf,EneLower) + endif + write (iout,*) 'My_Conf=',My_Conf,' EneLower=',EneLower + if (accepted) then + + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) elowest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +! Check against conformation repetitions. + irepet=conf_comp(varia,etot) + if (print_stat) then +#if defined(AIX) || defined(PGI) + open (istat,file=statname,position='append') +#else + open (istat,file=statname,access='append') +#endif + endif + call statprint(nacc,nfun,iretcode,etot,elowest) + if (refstr) then + call var_to_geom(nvar,varia) + call chainbuild + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),& !el cref(1,nstart_sup) + nsup,przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order',co + endif ! refstr + if (My_Conf) then + nout=nout+1 + write (iout,*) 'Writing new conformation',nout + if (refstr) then + write (istat,'(i5,16(1pe14.5))') nout,& + (energia(print_order(i)),i=1,nprint_ene),& + etot,rms,frac + else + if (print_stat) & + write (istat,'(i5,17(1pe14.5))') nout,& + (energia(print_order(i)),i=1,nprint_ene),etot + endif ! refstr + if (print_stat) close(istat) +! Print internal coordinates. + if (print_int) call briefout(nout,etot) +! Accumulate the newly accepted conf in the coord1 array, if it is different +! from all confs that are already there. + call compare_s1(n_thr,max_thread2,etot,varia,ii,& + enetb1,coord1,rms_deform,.true.,iprint) + write (iout,*) 'After compare_ss: n_thr=',n_thr + if (ii.eq.1 .or. ii.eq.3) then + write (iout,'(8f10.4)') & + (rad2deg*coord1(i,n_thr),i=1,nvar) + endif + else + write (iout,*) 'Conformation from cache, not written.' + endif ! My_Conf + + if (nrepm.gt.maxrepm) then + write (iout,'(a)') 'Too many conformation repetitions.' + goto 20 + endif +! Store the accepted conf. and its energy. + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + if (irepet.eq.0) call zapis(varia,etot) +! Lower the temperature, if necessary. + call cool + + else + + ntrial=ntrial+1 + endif ! accepted + endif ! overlap + + 30 continue + enddo ! accepted +! Check for time limit. + if (ovrtim()) WhatsUp=-1 + not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) & + .and. (Kwita.eq.0) + + enddo ! not_done + goto 21 + 20 WhatsUp=-3 + + 21 continue + runtime=tcpu() + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc,nfun,iretcode,etot,elowest) + write (iout,'(a)') & + 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) + if (it.ge.maxacc) & + write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + !(maxvar) (maxvar=6*maxres) + return + end subroutine do_mcm +#endif +!----------------------------------------------------------------------------- +#ifdef MPI + subroutine do_mcm(i_orig) + +! Monte-Carlo-with-Minimization calculations - parallel code. + use MPI_data + use control_data, only:refstr!,tag + use io_base, only:intout,briefout + use control, only:ovrtim,tcpu + use compare, only:contact,contact_fract + use minimm, only:minimize + use regularize_, only:fitsq +! use contact_, only:contact +! use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.MCM' +! include 'COMMON.CONTACTS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.INFO' +! include 'COMMON.CACHE' +!rc include 'COMMON.DEFORM' +!rc include 'COMMON.DEFORM1' +!rc include 'COMMON.DEFORM2' +! include 'COMMON.MINIM' +! include 'COMMON.NAMES' + logical :: accepted,over,error,lprint,not_done,similar,& + enelower,non_conv,flag,finish !,ovrtim + integer :: MoveType,nbond !,conf_comp + real(kind=8),dimension(6*nres) :: x1,varold1,varold,varia !(maxvar) (maxvar=6*maxres) + real(kind=8) :: elowest,eold + real(kind=8) :: przes(3),obr(3,3) + integer :: iparentx(max_threadss2) + integer :: iparentx1(max_threadss2) + integer :: imtasks(150),imtasks_n + real(kind=8) :: energia(0:n_ene) + +!el local variables + integer :: nfun,nodenum,i_orig,i,nf,nacc,it,nout,j,kkk,is,& + Kwita,iretcode,noverlap,nstart_grow,ierr,iitt,& + ii_grnum_d,ii_ennum_d,ii_hesnum_d,i_grnum_d,i_ennum_d,& + i_hesnum_d,i_minimiz,irepet + real(kind=8) :: etot,frac,eneglobal,RandOrPert,eold1,co,& + runtime,rms + +! if(.not.allocated(varsave)) allocate(varsave(maxvar,maxsave)) !(maxvar,maxsave) + print *,'Master entered DO_MCM' + nodenum = nprocs + + finish=.false. + imtasks_n=0 + do i=1,nodenum-1 + imtasks(i)=0 + enddo +!--------------------------------------------------------------------------- +! Initialize counters. +!--------------------------------------------------------------------------- +! Total number of generated confs. + ngen=0 +! Total number of moves. In general this won`t be equal to the number of +! attempted moves, because we may want to reject some "bad" confs just by +! overlap check. + nmove=0 +! Total number of temperature jumps. + ntherm=0 +! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +! motions. + allocate(nbond_move(nres)) !(maxres) + + ncache=0 + do i=1,nres + nbond_move(i)=0 + enddo +! Initialize total and accepted number of moves of various kind. + do i=0,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +! Total number of energy evaluations. + neneval=0 + nfun=0 + nsave=0 +! write (iout,*) 'RanFract=',RanFract + WhatsUp=0 + Kwita=0 +!---------------------------------------------------------------------------- +! Compute and print initial energies. +!---------------------------------------------------------------------------- + call intout + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + nf=0 + call etotal(energia) + etot = energia(0) + call enerprint(energia) +! Request energy computation from slave processors. + call geom_to_var(nvar,varia) +! write (iout,*) 'The VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + call minimize(etot,varia,iretcode,nfun) + call var_to_geom(nvar,varia) + call chainbuild + write (iout,*) 'etot from MINIMIZE:',etot +! write (iout,*) 'Tha VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + neneval=0 + eneglobal=1.0d99 + if (print_mc .gt. 0) write (iout,'(/80(1h*)/20x,a/80(1h*))') & + 'Enter Monte Carlo procedure.' + if (print_mc .gt. 0) write (iout,'(i5,1pe14.5)' ) i_orig,etot + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + elowest=etot + call zapis(varia,etot) +! diagnostics + call var_to_geom(nvar,varia) + call chainbuild + call etotal(energia) + if (print_mc.gt.0) write (iout,*) 'Initial energy:',etot +! end diagnostics + nacc=0 ! total # of accepted confs of the current processor. + nacc_tot=0 ! total # of accepted confs of all processors. + not_done=.true. +!---------------------------------------------------------------------------- +! Main loop. +!---------------------------------------------------------------------------- + it=0 + nout=0 + LOOP1:do while (not_done) + it=it+1 + if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') & + 'Beginning iteration #',it +! Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + noverlap=0 ! # of overlapping confs. + accepted=.false. + LOOP2:do while (.not. accepted) + + LOOP3:do while (imtasks_n.lt.nodenum-1.and..not.finish) + do i=1,nodenum-1 + if(imtasks(i).eq.0) then + is=i + exit + endif + enddo +! Retrieve the angles of previously accepted conformation + do j=1,nvar + varia(j)=varold(j) + enddo + call var_to_geom(nvar,varia) +! Rebuild the chain. + call chainbuild +! Heat up the system, if necessary. + call heat(over) +! If temperature cannot be further increased, stop. + if (over) then + finish=.true. + endif + MoveType=0 + nbond=0 +! write (iout,'(a)') 'Old variables:' +! write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) +! Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0) & + write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,1.0D0) +! print *,'after perturb',error,finish + if (error) finish = .true. + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& + MoveType,' returned from PERTURB.' + finish=.true. + write (*,'(/a,i7,a/)') 'Error - unknown MoveType=',& + MoveType,' returned from PERTURB.' + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0) & + write (iout,'(2a,i3)') 'Random-generated conformation',& + ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) + ngen=ngen+1 +! print *,'finish=',finish + if (etot-elowest.gt.overlap_cut) then + if (print_mc.gt.1) write (iout,'(a,1pe14.5)') & + 'Overlap detected in the current conf.; energy is',etot + if(iprint.gt.1.or.etot.lt.1d19) print *,& + 'Overlap detected in the current conf.; energy is',etot + neneval=neneval+1 + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,*) 'Too many overlapping confs.',& + ' etot, elowest, overlap_cut', etot, elowest, overlap_cut + finish=.true. + endif + else if (.not. finish) then +! Distribute tasks to processors +! print *,'Master sending order' + call MPI_SEND(12, 1, MPI_INTEGER, is, tag,& + CG_COMM, ierr) +! write (iout,*) '12: tag=',tag +! print *,'Master sent order to processor',is + call MPI_SEND(it, 1, MPI_INTEGER, is, tag,& + CG_COMM, ierr) +! write (iout,*) 'it: tag=',tag + call MPI_SEND(eold, 1, MPI_DOUBLE_PRECISION, is, tag,& + CG_COMM, ierr) +! write (iout,*) 'eold: tag=',tag + call MPI_SEND(varia(1), nvar, MPI_DOUBLE_PRECISION, & + is, tag,& + CG_COMM, ierr) +! write (iout,*) 'varia: tag=',tag + call MPI_SEND(varold(1), nvar, MPI_DOUBLE_PRECISION, & + is, tag,& + CG_COMM, ierr) +! write (iout,*) 'varold: tag=',tag +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + imtasks(is)=1 + imtasks_n=imtasks_n+1 +! End distribution + endif ! overlap + enddo LOOP3 + + flag = .false. + LOOP_RECV:do while(.not.flag) + do is=1, nodenum-1 + call MPI_IPROBE(is,tag,CG_COMM,flag,status,ierr) + if(flag) then + call MPI_RECV(iitt, 1, MPI_INTEGER, is, tag,& + CG_COMM, status, ierr) + call MPI_RECV(eold1, 1, MPI_DOUBLE_PRECISION, is, tag,& + CG_COMM, status, ierr) + call MPI_RECV(etot, 1, MPI_DOUBLE_PRECISION, is, tag,& + CG_COMM, status, ierr) + call MPI_RECV(varia(1), nvar, MPI_DOUBLE_PRECISION,is,tag,& + CG_COMM, status, ierr) + call MPI_RECV(varold1(1), nvar, MPI_DOUBLE_PRECISION, is, & + tag, CG_COMM, status, ierr) + call MPI_RECV(ii_grnum_d, 1, MPI_INTEGER, is, tag,& + CG_COMM, status, ierr) + call MPI_RECV(ii_ennum_d, 1, MPI_INTEGER, is, tag,& + CG_COMM, status, ierr) + call MPI_RECV(ii_hesnum_d, 1, MPI_INTEGER, is, tag,& + CG_COMM, status, ierr) + i_grnum_d=i_grnum_d+ii_grnum_d + i_ennum_d=i_ennum_d+ii_ennum_d + neneval = neneval+ii_ennum_d + i_hesnum_d=i_hesnum_d+ii_hesnum_d + i_minimiz=i_minimiz+1 + imtasks(is)=0 + imtasks_n=imtasks_n-1 + exit + endif + enddo + enddo LOOP_RECV + + if(print_mc.gt.0) write (iout,'(a,i6,a,i6,a,i6,a,1pe16.6)') & + 'From Worker #',is,' iitt',iitt,& + ' Conformation:',ngen,' energy:',etot +!-------------------------------------------------------------------------- +!... Do Metropolis test +!-------------------------------------------------------------------------- + call metropolis(nvar,varia,varold1,etot,eold1,accepted,& + similar,EneLower) + if(iitt.ne.it.and..not.similar) then + call metropolis(nvar,varia,varold,etot,eold,accepted,& + similar,EneLower) + accepted=enelower + endif + if(etot.lt.eneglobal)eneglobal=etot +! if(mod(it,100).eq.0) + write(iout,*)'CHUJOJEB ',neneval,eneglobal + if (accepted) then +! Write the accepted conformation. + nout=nout+1 + if (refstr) then + call var_to_geom(nvar,varia) + call chainbuild + kkk=1 + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk),& + nsup,przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & + 'RMS deviation from the reference structure:',rms,& + ' % of native contacts:',frac*100,' contact order:',co + endif ! refstr + if (print_mc.gt.0) & + write (iout,*) 'Writing new conformation',nout + if (print_stat) then + call var_to_geom(nvar,varia) +#if defined(AIX) || defined(PGI) + open (istat,file=statname,position='append') +#else + open (istat,file=statname,access='append') +#endif + if (refstr) then + write (istat,'(i5,16(1pe14.5))') nout,& + (energia(print_order(i)),i=1,nprint_ene),& + etot,rms,frac + else + write (istat,'(i5,16(1pe14.5))') nout,& + (energia(print_order(i)),i=1,nprint_ene),etot + endif ! refstr + close(istat) + endif ! print_stat +! Print internal coordinates. + if (print_int) call briefout(nout,etot) + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) elowest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +! Check against conformation repetitions. + irepet=conf_comp(varia,etot) + if (nrepm.gt.maxrepm) then + if (print_mc.gt.0) & + write (iout,'(a)') 'Too many conformation repetitions.' + finish=.true. + endif +! Store the accepted conf. and its energy. + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + if (irepet.eq.0) call zapis(varia,etot) +! Lower the temperature, if necessary. + call cool + else + ntrial=ntrial+1 + endif ! accepted + 30 continue + if(finish.and.imtasks_n.eq.0)exit LOOP2 + enddo LOOP2 ! accepted +! Check for time limit. + not_done = (it.lt.max_mcm_it) .and. (nacc_tot.lt.maxacc) + if(.not.not_done .or. finish) then + if(imtasks_n.gt.0) then + not_done=.true. + else + not_done=.false. + endif + finish=.true. + endif + enddo LOOP1 ! not_done + runtime=tcpu() + if (print_mc.gt.0) then + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc,nfun,iretcode,etot,elowest) + write (iout,'(a)') & + 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) + if (it.ge.maxacc) & + write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + endif +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + do is=1,nodenum-1 + call MPI_SEND(999, 1, MPI_INTEGER, is, tag,& + CG_COMM, ierr) + enddo + return + end subroutine do_mcm +!----------------------------------------------------------------------------- + subroutine execute_slave(nodeinfo,iprint) + + use MPI_data + use minimm, only:minimize +! use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.TIME1' +! include 'COMMON.IOUNITS' +!rc include 'COMMON.DEFORM' +!rc include 'COMMON.DEFORM1' +!rc include 'COMMON.DEFORM2' +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.INFO' +! include 'COMMON.MINIM' + character(len=10) :: nodeinfo + real(kind=8),dimension(6*nres) :: x,x1 !(maxvar) (maxvar=6*maxres) + integer :: nfun,iprint,i_switch,ierr,i_grnum_d,i_ennum_d,& + i_hesnum_d,iitt,iretcode,iminrep + real(kind=8) :: ener,energyx + + nodeinfo='chujwdupe' +! print *,'Processor:',MyID,' Entering execute_slave' + tag=0 +! call MPI_SEND(nodeinfo, 10, MPI_CHARACTER, 0, tag, +! & CG_COMM, ierr) + +1001 call MPI_RECV(i_switch, 1, MPI_INTEGER, 0, tag,& + CG_COMM, status, ierr) +! write(iout,*)'12: tag=',tag + if(iprint.ge.2)print *, MyID,' recv order ',i_switch + if (i_switch.eq.12) then + i_grnum_d=0 + i_ennum_d=0 + i_hesnum_d=0 + call MPI_RECV(iitt, 1, MPI_INTEGER, 0, tag,& + CG_COMM, status, ierr) +! write(iout,*)'12: tag=',tag + call MPI_RECV(ener, 1, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, status, ierr) +! write(iout,*)'ener: tag=',tag + call MPI_RECV(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, status, ierr) +! write(iout,*)'x: tag=',tag + call MPI_RECV(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, status, ierr) +! write(iout,*)'x1: tag=',tag +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif +! print *,'calling minimize' + call minimize(energyx,x,iretcode,nfun) + if(iprint.gt.0) & + write(iout,100)'minimized energy = ',energyx,& + ' # funeval:',nfun,' iret ',iretcode + write(*,100)'minimized energy = ',energyx,& + ' # funeval:',nfun,' iret ',iretcode + 100 format(a20,f10.5,a12,i5,a6,i2) + if(iretcode.eq.10) then + do iminrep=2,3 + if(iprint.gt.1) & + write(iout,*)' ... not converged - trying again ',iminrep + call minimize(energyx,x,iretcode,nfun) + if(iprint.gt.1) & + write(iout,*)'minimized energy = ',energyx,& + ' # funeval:',nfun,' iret ',iretcode + if(iretcode.ne.10)go to 812 + enddo + if(iretcode.eq.10) then + if(iprint.gt.1) & + write(iout,*)' ... not converged again - giving up' + go to 812 + endif + endif +812 continue +! print *,'Sending results' + call MPI_SEND(iitt, 1, MPI_INTEGER, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(ener, 1, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(energyx, 1, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(i_grnum_d, 1, MPI_INTEGER, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(nfun, 1, MPI_INTEGER, 0, tag,& + CG_COMM, ierr) + call MPI_SEND(i_hesnum_d, 1, MPI_INTEGER, 0, tag,& + CG_COMM, ierr) +! print *,'End sending' + go to 1001 + endif + + return + end subroutine execute_slave +#endif +!----------------------------------------------------------------------------- + subroutine heat(over) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' + logical :: over +! Check if there`s a need to increase temperature. + if (ntrial.gt.maxtrial) then + if (NstepH.gt.0) then + if (dabs(Tcur-TMax).lt.1.0D-7) then + if (print_mc.gt.0) & + write (iout,'(/80(1h*)/a,f8.3,a/80(1h*))') & + 'Upper limit of temperature reached. Terminating.' + over=.true. + Tcur=Tmin + else + Tcur=Tcur*TstepH + if (Tcur.gt.Tmax) Tcur=Tmax + betbol=1.0D0/(Rbol*Tcur) + if (print_mc.gt.0) & + write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') & + 'System heated up to ',Tcur,' K; BetBol:',betbol + ntherm=ntherm+1 + ntrial=0 + over=.false. + endif + else + if (print_mc.gt.0) & + write (iout,'(a)') & + 'Maximum number of trials in a single MCM iteration exceeded.' + over=.true. + Tcur=Tmin + endif + else + over=.false. + endif + return + end subroutine heat +!----------------------------------------------------------------------------- + subroutine cool + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' + if (nstepC.gt.0 .and. dabs(Tcur-Tmin).gt.1.0D-7) then + Tcur=Tcur/TstepC + if (Tcur.lt.Tmin) Tcur=Tmin + betbol=1.0D0/(Rbol*Tcur) + if (print_mc.gt.0) & + write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') & + 'System cooled down up to ',Tcur,' K; BetBol:',betbol + endif + return + end subroutine cool +!----------------------------------------------------------------------------- + subroutine perturb(error,lprint,MoveType,nbond,max_phi) + + use geometry + use energy, only:nnt,nct,itype + use md_calc, only:bond_move +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer,parameter :: MMaxSideMove=100 +! include 'COMMON.MCM' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +!rc include 'COMMON.DEFORM1' + logical :: error,lprint,fail + integer :: MoveType,nbond,end_select,ind_side(MMaxSideMove) + real(kind=8) :: max_phi + real(kind=8) :: psi!,gen_psi +!el external iran_num +!el integer iran_num + integer :: ifour + +!!! local variables - el + integer :: itrial,iiwin,iwindow,isctry,i,icount,j,nstart,& + nside_move,inds,indx,ii,iti + real(kind=8) :: bond_prob,theta_new + + data ifour /4/ + error=.false. + lprint=.false. +! Perturb the conformation according to a randomly selected move. + call SelectMove(MoveType) +! write (iout,*) 'MoveType=',MoveType + itrial=0 + goto (100,200,300,400,500) MoveType +!------------------------------------------------------------------------------ +! Backbone N-bond move. +! Select the number of bonds (length of the segment to perturb). + 100 continue + if (itrial.gt.1000) then + write (iout,'(a)') 'Too many attempts at multiple-bond move.' + error=.true. + return + endif + bond_prob=ran_number(0.0D0,sumpro_bond(nbm)) +! print *,'sumpro_bond(nbm)=',sumpro_bond(nbm), +! & ' Bond_prob=',Bond_Prob + do i=1,nbm-1 +! print *,i,Bond_Prob,sumpro_bond(i),sumpro_bond(i+1) + if (bond_prob.ge.sumpro_bond(i) .and. & + bond_prob.le.sumpro_bond(i+1)) then + nbond=i+1 + goto 10 + endif + enddo + write (iout,'(2a)') 'In PERTURB: Error - number of bonds',& + ' to move out of range.' + error=.true. + return + 10 continue + if (nwindow.gt.0) then +! Select the first residue to perturb + iwindow=iran_num(1,nwindow) + print *,'iwindow=',iwindow + iiwin=1 + do while (winlen(iwindow).lt.nbond) + iwindow=iran_num(1,nwindow) + iiwin=iiwin+1 + if (iiwin.gt.1000) then + write (iout,'(a)') 'Cannot select moveable residues.' + error=.true. + return + endif + enddo + nstart=iran_num(winstart(iwindow),winend(iwindow)) + else + nstart = iran_num(koniecl+2,nres-nbond-koniecl) +!d print *,'nres=',nres,' nbond=',nbond,' koniecl=',koniecl, +!d & ' nstart=',nstart + endif + psi = gen_psi() + if (psi.eq.0.0) then + error=.true. + return + endif + if (print_mc.gt.1) write (iout,'(a,i4,a,i4,a,f8.3)') & + 'PERTURB: nbond=',nbond,' nstart=',nstart,' psi=',psi*rad2deg +!d print *,'nstart=',nstart + call bond_move(nbond,nstart,psi,.false.,error) + if (error) then + write (iout,'(2a)') & + 'Could not define reference system in bond_move, ',& + 'choosing ahother segment.' + itrial=itrial+1 + goto 100 + endif + nbond_move(nbond)=nbond_move(nbond)+1 + moves(1)=moves(1)+1 + nmove=nmove+1 + return +!------------------------------------------------------------------------------ +! Backbone endmove. Perturb a SINGLE angle of a residue close to the end of +! the chain. + 200 continue + lprint=.true. +! end_select=iran_num(1,2*koniecl) +! if (end_select.gt.koniecl) then +! end_select=nphi-(end_select-koniecl) +! else +! end_select=koniecl+3 +! endif +! if (nwindow.gt.0) then +! iwin=iran_num(1,nwindow) +! i1=max0(4,winstart(iwin)) +! i2=min0(winend(imin)+2,nres) +! end_select=iran_num(i1,i2) +! else +! iselect = iran_num(1,nmov_var) +! jj = 0 +! do i=1,nphi +! if (isearch_tab(i).eq.1) jj = jj+1 +! if (jj.eq.iselect) then +! end_select=i+3 +! exit +! endif +! enddo +! endif + end_select = iran_num(4,nres) + psi=max_phi*gen_psi() + if (psi.eq.0.0D0) then + error=.true. + return + endif + phi(end_select)=pinorm(phi(end_select)+psi) + if (print_mc.gt.1) write (iout,'(a,i4,a,f8.3,a,f8.3)') & + 'End angle',end_select,' moved by ',psi*rad2deg,' new angle:',& + phi(end_select)*rad2deg +! if (end_select.gt.3) +! & theta(end_select-1)=gen_theta(itype(end_select-2), +! & phi(end_select-1),phi(end_select)) +! if (end_select.lt.nres) +! & theta(end_select)=gen_theta(itype(end_select-1), +! & phi(end_select),phi(end_select+1)) +!d print *,'nres=',nres,' end_select=',end_select +!d print *,'theta',end_select-1,theta(end_select-1) +!d print *,'theta',end_select,theta(end_select) + moves(2)=moves(2)+1 + nmove=nmove+1 + lprint=.false. + return +!------------------------------------------------------------------------------ +! Side chain move. +! Select the number of SCs to perturb. + 300 isctry=0 + 301 nside_move=iran_num(1,MaxSideMove) +! print *,'nside_move=',nside_move,' MaxSideMove',MaxSideMove +! Select the indices. + do i=1,nside_move + icount=0 + 111 inds=iran_num(nnt,nct) + icount=icount+1 + if (icount.gt.1000) then + write (iout,'(a)')'Error - cannot select side chains to move.' + error=.true. + return + endif + if (itype(inds).eq.10) goto 111 + do j=1,i-1 + if (inds.eq.ind_side(j)) goto 111 + enddo + do j=1,i-1 + if (inds.lt.ind_side(j)) then + indx=j + goto 112 + endif + enddo + indx=i + 112 do j=i,indx+1,-1 + ind_side(j)=ind_side(j-1) + enddo + 113 ind_side(indx)=inds + enddo +! Carry out perturbation. + do i=1,nside_move + ii=ind_side(i) + iti=itype(ii) + call gen_side(iti,theta(ii+1),alph(ii),omeg(ii),fail) + if (fail) then + isctry=isctry+1 + if (isctry.gt.1000) then + write (iout,'(a)') 'Too many errors in SC generation.' + error=.true. + return + endif + goto 301 + endif + if (print_mc.gt.1) write (iout,'(2a,i4,a,2f8.3)') & + 'Side chain ',restyp(iti),ii,' moved to ',& + alph(ii)*rad2deg,omeg(ii)*rad2deg + enddo + moves(3)=moves(3)+1 + nmove=nmove+1 + return +!------------------------------------------------------------------------------ +! THETA move + 400 end_select=iran_num(3,nres) + theta_new=gen_theta(itype(end_select),phi(end_select),& + phi(end_select+1)) + if (print_mc.gt.1) write (iout,'(a,i3,a,f8.3,a,f8.3)') & + 'Theta ',end_select,' moved from',theta(end_select)*rad2deg,& + ' to ',theta_new*rad2deg + theta(end_select)=theta_new + moves(4)=moves(4)+1 + nmove=nmove+1 + return +!------------------------------------------------------------------------------ +! Error returned from SelectMove. + 500 error=.true. + return + end subroutine perturb +!----------------------------------------------------------------------------- + subroutine SelectMove(MoveType) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' + +!!! local variables - el + integer :: i,MoveType + real(kind=8) :: what_move + + what_move=ran_number(0.0D0,sumpro_type(MaxMoveType)) + do i=1,MaxMoveType + if (what_move.ge.sumpro_type(i-1).and. & + what_move.lt.sumpro_type(i)) then + MoveType=i + return + endif + enddo + write (iout,'(a)') & + 'Fatal error in SelectMoveType: cannot select move.' + MoveType=MaxMoveType+1 + return + end subroutine SelectMove +!----------------------------------------------------------------------------- + real(kind=8) function gen_psi() + + use geometry_data, only: angmin,pi +!el implicit none + integer :: i + real(kind=8) :: x !,ran_number +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' + x=0.0D0 + do i=1,100 + x=ran_number(-pi,pi) + if (dabs(x).gt.angmin) then + gen_psi=x + return + endif + enddo + write (iout,'(a)')'From Gen_Psi: Cannot generate angle increment.' + gen_psi=0.0D0 + return + end function gen_psi +!----------------------------------------------------------------------------- + subroutine metropolis(n,xcur,xold,ecur,eold,accepted,similar,enelower) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +!rc include 'COMMON.DEFORM' + integer :: n + real(kind=8) :: ecur,eold,xx,bol !,ran_number + real(kind=8),dimension(n) :: xcur,xold + real(kind=8) :: ecut1 ,ecut2 ,tola + logical :: accepted,similar,not_done,enelower + logical :: lprn + +!!! local variables - el + real(kind=8) :: xxh,difene,reldife + + data ecut1 /-1.0D-5/,ecut2 /5.0D-3/,tola/5.0D0/ +! ecut1=-5*enedif +! ecut2=50*enedif +! tola=5.0d0 +! Set lprn=.true. for debugging. + lprn=.false. + if (lprn) & +!el write(iout,*)'enedif',enedif,' ecut1',ecut1,' ecut2',ecut2 + write(iout,*)' ecut1',ecut1,' ecut2',ecut2 + similar=.false. + enelower=.false. + accepted=.false. +! Check if the conformation is similar. + difene=ecur-eold + reldife=difene/dmax1(dabs(eold),dabs(ecur),1.0D0) + if (lprn) then + write (iout,*) 'Metropolis' + write(iout,*)'ecur,eold,difene,reldife',ecur,eold,difene,reldife + endif +! If energy went down remarkably, we accept the new conformation +! unconditionally. +!jp if (reldife.lt.ecut1) then + if (difene.lt.ecut1) then + accepted=.true. + EneLower=.true. + if (lprn) write (iout,'(a)') & + 'Conformation accepted, because energy has lowered remarkably.' +! elseif (reldife.lt.ecut2 .and. dif_ang(nphi,xcur,xold).lt.tola) +!jp elseif (reldife.lt.ecut2) + elseif (difene.lt.ecut2) & + then +! Reject the conf. if energy has changed insignificantly and there is not +! much change in conformation. + if (lprn) & + write (iout,'(2a)') 'Conformation rejected, because it is',& + ' similar to the preceding one.' + accepted=.false. + similar=.true. + else +! Else carry out Metropolis test. + EneLower=.false. + xx=ran_number(0.0D0,1.0D0) + xxh=betbol*difene + if (lprn) & + write (iout,*) 'betbol=',betbol,' difene=',difene,' xxh=',xxh + if (xxh.gt.50.0D0) then + bol=0.0D0 + else + bol=exp(-xxh) + endif + if (lprn) write (iout,*) 'bol=',bol,' xx=',xx + if (bol.gt.xx) then + accepted=.true. + if (lprn) write (iout,'(a)') & + 'Conformation accepted, because it passed Metropolis test.' + else + accepted=.false. + if (lprn) write (iout,'(a)') & + 'Conformation rejected, because it did not pass Metropolis test.' + endif + endif +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + return + end subroutine metropolis +!----------------------------------------------------------------------------- + integer function conf_comp(x,ene) + + use geometry_data, only: nphi +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' + real(kind=8) :: etol, angtol + real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) + real(kind=8) :: difa !dif_ang, + +!!! local variables - el + integer :: ii,i + real(kind=8) :: ene + + data etol /0.1D0/, angtol /20.0D0/ + do ii=nsave,1,-1 +! write (iout,*) 'ii=',ii,'ene=',ene,esave(ii),dabs(ene-esave(ii)) + if (dabs(ene-esave(ii)).lt.etol) then + difa=dif_ang(nphi,x,varsave(1,ii)) +! do i=1,nphi +! write(iout,'(i3,3f8.3)')i,rad2deg*x(i), +! & rad2deg*varsave(i,ii) +! enddo +! write(iout,*) 'ii=',ii,' difa=',difa,' angtol=',angtol + if (difa.le.angtol) then + if (print_mc.gt.0) then + write (iout,'(a,i5,2(a,1pe15.4))') & + 'Current conformation matches #',ii,& + ' in the store array ene=',ene,' esave=',esave(ii) +! write (*,'(a,i5,a)') 'Current conformation matches #',ii, +! & ' in the store array.' + endif ! print_mc.gt.0 + if (print_mc.gt.1) then + do i=1,nphi + write(iout,'(i3,3f8.3)')i,rad2deg*x(i),& + rad2deg*varsave(i,ii) + enddo + endif ! print_mc.gt.1 + nrepm=nrepm+1 + conf_comp=ii + return + endif + endif + enddo + conf_comp=0 + return + end function conf_comp +!----------------------------------------------------------------------------- + real(kind=8) function dif_ang(n,x,y) + + use geometry_data, only: dwapi +!el implicit none + integer :: i,n + real(kind=8),dimension(n) :: x,y + real(kind=8) :: w,wa,dif,difa +!el real(kind=8) :: pinorm +! include 'COMMON.GEO' + wa=0.0D0 + difa=0.0D0 + do i=1,n + dif=dabs(pinorm(y(i)-x(i))) + if (dabs(dif-dwapi).lt.dif) dif=dabs(dif-dwapi) + w=1.0D0-(2.0D0*(i-1)/(n-1)-1.0D0)**2+1.0D0/n + wa=wa+w + difa=difa+dif*dif*w + enddo + dif_ang=rad2deg*dsqrt(difa/wa) + return + end function dif_ang +!----------------------------------------------------------------------------- + subroutine add2cache(n1,n2,ncache,nvar,SourceID,CachSrc,ecur,xcur,ecache,xcache) + +! implicit none +! include 'COMMON.GEO' +! include 'COMMON.IOUNITS' + integer :: n1,n2,ncache,nvar,SourceID,CachSrc(n2) + integer :: i,ii,j + real(kind=8) :: ecur,xcur(nvar),ecache(n2),xcache(n1,n2) +!d write (iout,*) 'Enter ADD2CACHE ncache=',ncache ,' ecur',ecur +!d write (iout,'(10f8.3)') (rad2deg*xcur(i),i=1,nvar) +!d write (iout,*) 'Old CACHE array:' +!d do i=1,ncache +!d write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) +!d write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) +!d enddo + + i=ncache + do while (i.gt.0 .and. ecur.lt.ecache(i)) + i=i-1 + enddo + i=i+1 +!d write (iout,*) 'i=',i,' ncache=',ncache + if (ncache.eq.n2) then + write (iout,*) 'Cache dimension exceeded',ncache,n2 + write (iout,*) 'Highest-energy conformation will be removed.' + ncache=ncache-1 + endif + do ii=ncache,i,-1 + ecache(ii+1)=ecache(ii) + CachSrc(ii+1)=CachSrc(ii) + do j=1,nvar + xcache(j,ii+1)=xcache(j,ii) + enddo + enddo + ecache(i)=ecur + CachSrc(i)=SourceID + do j=1,nvar + xcache(j,i)=xcur(j) + enddo + ncache=ncache+1 +!d write (iout,*) 'New CACHE array:' +!d do i=1,ncache +!d write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) +!d write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) +!d enddo + return + end subroutine add2cache +!----------------------------------------------------------------------------- + subroutine rm_from_cache(i,n1,n2,ncache,nvar,CachSrc,ecache,xcache) + +! implicit none +! include 'COMMON.GEO' +! include 'COMMON.IOUNITS' + integer :: n1,n2,ncache,nvar,CachSrc(n2) + integer :: i,ii,j + real(kind=8) :: ecache(n2),xcache(n1,n2) + +!d write (iout,*) 'Enter RM_FROM_CACHE' +!d write (iout,*) 'Old CACHE array:' +!d do ii=1,ncache +!d write (iout,*)'i=',ii,' ecache=',ecache(ii),' CachSrc',CachSrc(ii) +!d write (iout,'(10f8.3)') (rad2deg*xcache(j,ii),j=1,nvar) +!d enddo + + do ii=i+1,ncache + ecache(ii-1)=ecache(ii) + CachSrc(ii-1)=CachSrc(ii) + do j=1,nvar + xcache(j,ii-1)=xcache(j,ii) + enddo + enddo + ncache=ncache-1 +!d write (iout,*) 'New CACHE array:' +!d do i=1,ncache +!d write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) +!d write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) +!d enddo + return + end subroutine rm_from_cache +!----------------------------------------------------------------------------- +! mcm.F io_mcm +!----------------------------------------------------------------------------- + subroutine statprint(it,nfun,iretcode,etot,elowest) + + use control_data, only: MaxMoveType,minim + use control, only: tcpu + use mcm_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +! include 'COMMON.MCM' +!el local variables + integer :: it,nfun,iretcode,i + real(kind=8) :: etot,elowest,fr_mov_i + + if (minim) then + write (iout,& + '(80(1h*)/a,i5,a,1pe14.5,a,1pe14.5/a,i3,a,i10,a,i5,a,i5)') & + 'Finished iteration #',it,' energy is',etot,& + ' lowest energy:',elowest,& + 'SUMSL return code:',iretcode,& + ' # of energy evaluations:',neneval,& + '# of temperature jumps:',ntherm,& + ' # of minima repetitions:',nrepm + else + write (iout,'(80(1h*)/a,i8,a,1pe14.5,a,1pe14.5)') & + 'Finished iteration #',it,' energy is',etot,& + ' lowest energy:',elowest + endif + write (iout,'(/4a)') & + 'Kind of move ',' total',' accepted',& + ' fraction' + write (iout,'(58(1h-))') + do i=-1,MaxMoveType + if (moves(i).eq.0) then + fr_mov_i=0.0d0 + else + fr_mov_i=dfloat(moves_acc(i))/dfloat(moves(i)) + endif + write(iout,'(a,2i15,f10.5)')MovTypID(i),moves(i),moves_acc(i),& + fr_mov_i + enddo + write (iout,'(a,2i15,f10.5)') 'total ',nmove,nacc_tot,& + dfloat(nacc_tot)/dfloat(nmove) + write (iout,'(58(1h-))') + write (iout,'(a,1pe12.4)') 'Elapsed time:',tcpu() + return + end subroutine statprint +!----------------------------------------------------------------------------- + subroutine zapis(varia,etot) + + use geometry_data, only: nres,rad2deg,nvar + use mcm_data + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + use MPI_data !include 'COMMON.INFO' + include 'mpif.h' +#endif +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' + integer,dimension(nsave) :: itemp + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + logical :: lprint +!el local variables + integer :: j,i,maxvar + real(kind=8) :: etot + +!el allocate(esave(nsave)) !(maxsave) + + maxvar=6*nres + lprint=.false. + if (lprint) then + write (iout,'(a,i5,a,i5)') 'Enter ZAPIS NSave=',Nsave,& + ' MaxSave=',MaxSave + write (iout,'(a)') 'Current energy and conformation:' + write (iout,'(1pe14.5)') etot + write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) + endif +! Shift the contents of the esave and varsave arrays if filled up. + call add2cache(6*nres,nsave,nsave,nvar,MyID,itemp,& + etot,varia,esave,varsave) + if (lprint) then + write (iout,'(a)') 'Energies and the VarSave array.' + do i=1,nsave + write (iout,'(i5,1pe14.5)') i,esave(i) + write (iout,'(10f8.3)') (rad2deg*varsave(j,i),j=1,nvar) + enddo + endif + return + end subroutine zapis +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + subroutine alloc_MCM_arrays + + use energy_data, only: max_ene + use MPI_data +! common.mce +! common /mce/ + allocate(entropy(-max_ene-4:max_ene)) !(-max_ene-4:max_ene) + allocate(nhist(-max_ene:max_ene)) !(-max_ene:max_ene) + allocate(nminima(maxsave)) !(maxsave) +! common /pool/ + allocate(xpool(6*nres,max_pool)) !(maxvar,max_pool)(maxvar=6*maxres) + allocate(epool(max_pool)) !(max_pool) +! commom.mcm +! common /mcm/ + if(.not.allocated(nsave_part)) allocate(nsave_part(nctasks)) !(max_cg_procs) +! common /move/ +! in io: mcmread +! real(kind=8),dimension(:),allocatable :: sumpro_type !(0:MaxMoveType) + allocate(sumpro_bond(0:nres)) !(0:maxres) + allocate(nbond_move(nres),nbond_acc(nres)) !(maxres) + allocate(moves(-1:MaxMoveType+1),moves_acc(-1:MaxMoveType+1)) !(-1:MaxMoveType+1) +! common /accept_stats/ +! allocate(nacc_part !(0:MaxProcs) !el nie uzywane??? +! common /windows/ in io: mcmread +! allocate(winstart,winend,winlen !(maxres) +! common /moveID/ +!el allocate(MovTypID(-1:MaxMoveType+1)) !(-1:MaxMoveType+1) +! common.var +! common /oldgeo/ + allocate(varsave(nres*6,maxsave)) !(maxvar,maxsave)(maxvar=6*maxres) + allocate(esave(maxsave)) !(maxsave) + allocate(Origin(maxsave)) !(maxsave) + + return + end subroutine alloc_MCM_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module mcm_md diff --git a/source/unres/MCM_MD.f90 b/source/unres/MCM_MD.f90 deleted file mode 100644 index afb31bb..0000000 --- a/source/unres/MCM_MD.f90 +++ /dev/null @@ -1,3514 +0,0 @@ - module mcm_md -!----------------------------------------------------------------------------- - use io_units - use names - use math - use geometry_data, only: nres,nvar,rad2deg - use random, only: iran_num,ran_number - use MD_data - use MCM_data - use geometry - use energy - - implicit none -!----------------------------------------------------------------------------- -! Max. number of move types in MCM -! integer,parameter :: maxmovetype=4 -!----------------------------------------------------------------------------- -! Max. number of conformations in Master's cache array - integer,parameter :: max_cache=10 -!----------------------------------------------------------------------------- -! Max. number of stored confs. in MC/MCM simulation -! integer,parameter :: maxsave=20 -!----------------------------------------------------------------------------- -! Number of threads in deformation - integer,parameter :: max_thread=4, max_thread2=2*max_thread -!----------------------------------------------------------------------------- -! Number of structures to compare at t=0 - integer,parameter :: max_threadss=8,max_threadss2=2*max_threadss -!----------------------------------------------------------------------------- -! Max. number of conformations in the pool - integer,parameter :: max_pool=10 -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! commom.cache -! common /cache/ - integer :: ncache -! integer,dimension(max_cache) :: CachSrc nie używane -! integer,dimension(max_cache) :: isent,iused -! logical :: cache_update -! real(kind=8),dimension(max_cache) :: ecache -! real(kind=8),dimension(:,:),allocatable :: xcache !(maxvar,max_cache) -!----------------------------------------------------------------------------- -! common.mce -! common /mce/ -! real(kind=8) :: emin,emax - real(kind=8),dimension(:),allocatable :: entropy !(-max_ene-4:max_ene) - real(kind=8),dimension(:),allocatable :: nhist !(-max_ene:max_ene) - real(kind=8),dimension(:),allocatable :: nminima !(maxsave) -! logical :: ent_read - logical :: multican - integer :: indminn,indmaxx -! common /pool/ - integer :: npool -! real(kind=8) :: pool_fraction - real(kind=8),dimension(:,:),allocatable :: xpool !(maxvar,max_pool) - real(kind=8),dimension(:),allocatable :: epool !(max_pool) -! common /mce_counters/ -!------------------------------------------------------------------------------ -!... Following COMMON block contains variables controlling motion. -!------------------------------------------------------------------------------ -! common /move/ -! real(kind=8),dimension(0:MaxMoveType) :: sumpro_type !(0:MaxMoveType) - real(kind=8),dimension(:),allocatable :: sumpro_bond !(0:maxres) - integer :: koniecl,Nbm,MaxSideMove!,nmove - integer,dimension(:),allocatable :: nbond_move,nbond_acc !(maxres) -! integer,dimension(-1:MaxMoveType+1) :: moves,moves_acc !(-1:MaxMoveType+1) -! common /accept_stats/ -! integer :: nacc_tot - integer,dimension(:),allocatable :: nacc_part !(0:MaxProcs) !el nie uzywane??? -! common /windows/ -! integer :: nwindow -! integer,dimension(:),allocatable :: winstart,winend,winlen !(maxres) -! common /moveID/ -! character(len=16),dimension(-1:MaxMoveType+1) :: MovTypID !(-1:MaxMoveType+1) -!------------------------------------------------------------------------------ -!... koniecl - the number of bonds to be considered "end bonds" subjected to -!... end moves; -!... Nbm - The maximum length of N-bond segment to be moved; -!... MaxSideMove - maximum number of side chains subjected to local moves -!... simultaneously; -!... nmove - the current number of attempted moves; -!... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... -!... moves; -!... nendmove - number of endmoves; -!... nbackmove - number of backbone moves; -!... nsidemove - number of local side chain moves; -!... sumpro_type(*) - array that stores the lower and upper boundary of the -!... random-number range that determines the type of move -!... (N-bond, backbone or side chain); -!... sumpro_bond(*) - array that stores the probabilities to perform bond -!... moves of consecutive segment length. -!... winstart(*) - the starting position of the perturbation window; -!... winend(*) - the end position of the perturbation window; -!... winlen(*) - length of the perturbation window; -!... nwindow - the number of perturbation windows (0 - entire chain). -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! compare_s1.F -!----------------------------------------------------------------------------- - subroutine compare_s1(n_thr,num_thread_save,energyx,x,icomp,enetbss,& - coordss,rms_d,modif,iprint) - -! This subroutine compares the new conformation, whose variables are in X -! with the previously accumulated conformations whose energies and variables -! are stored in ENETBSS and COORDSS, respectively. The meaning of other -! variables is as follows: -! -! N_THR - on input the previous # of accumulated confs, on output the current -! # of accumulated confs. -! N_REPEAT - an array that indicates how many times the structure has already -! been used to start the reversed-reversing procedure. Addition of -! a new structure replacement of a structure with a similar, but -! lower-energy structure resets the respective entry in N_REPEAT to zero -! I9 - output unit -! ENERGYX,X - the energy and variables of the new conformations. -! ICOMP - comparison result: -! 0 - the new structure is similar to one of the previous ones and does -! not have a remarkably lower energy and is therefore rejected; -! 1 - the new structure is different and is added to the set, because -! there is still room in the COORDSS and ENETBSS arrays; -! 2 - the new structure is different, but higher in energy than any -! previous one and is therefore rejected -! 3 - there is no more room in the COORDSS and ENETBSS arrays, but -! the new structure is lower in energy than at least the highest- -! energy previous structure and therefore replaces it. -! 9 - the new structure is similar to a number of previous structures, -! but has a remarkably lower energy than any of them; therefore -! replaces all these structures; -! MODIF - a logical variable that shows whether to include the new structure -! in the set of accumulated structures - -! implicit real*8 (a-h,o-z) - use geometry_data - use regularize_, only:fitsq -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -!rc include 'COMMON.DEFORM' -! include 'COMMON.IOUNITS' -!el#ifdef UNRES -!el use geometry_data !include 'COMMON.CHAIN' -!el#endif - - real(kind=8),dimension(6*nres) :: x,x1 !(maxvar) (maxvar=6*maxres) - real(kind=8) :: przes(3),obrot(3,3) - integer :: list(max_thread) - logical :: non_conv,modif - real(kind=8) :: enetbss(max_threadss) - real(kind=8) :: coordss(6*nres,max_threadss) - -!!! local variables - el - integer :: n_thr,num_thread_save,icomp,minimize_s_flag,iprint - real(kind=8) :: energyx,energyy,rms_d - integer :: nlist,k,kk,j,i,iresult - real(kind=8) :: enex_jp,roznica - - nlist=0 -#ifdef UNRES - call var_to_geom(nvar,x) - call chainbuild - do k=1,2*nres - do kk=1,3 - cref(kk,k,1)=c(kk,k) - enddo - enddo -#endif -! write(iout,*)'*ene=',energyx - j=0 - enex_jp=-1.0d+99 - do i=1,n_thr - do k=1,nvar - x1(k)=coordss(k,i) - enddo - if (iprint.gt.3) then - write (iout,*) 'Compare_ss, i=',i - write (iout,*) 'New structure Energy:',energyx - write (iout,'(10f8.3)') (rad2deg*x(k),k=1,nvar) - write (iout,*) 'Template structure Energy:',enetbss(i) - write (iout,'(10f8.3)') (rad2deg*x1(k),k=1,nvar) - endif - -#ifdef UNRES - call var_to_geom(nvar,x1) - call chainbuild -!d write(iout,*)'C and CREF' -!d write(iout,'(i5,3f10.5,5x,3f10.5)')(k,(c(j,k),j=1,3), -!d & (cref(j,k),j=1,3),k=1,nres) - call fitsq(roznica,c(1,1),cref(1,1,1),nres,przes,obrot,non_conv) - if (non_conv) then - print *,'Problems in FITSQ!!!' - print *,'X' - print '(10f8.3)',(x(k),k=1,nvar) - print *,'X1' - print '(10f8.3)',(x1(k),k=1,nvar) - print *,'C and CREF' - print '(i5,3f10.5,5x,3f10.5)',(k,(c(j,k),j=1,3),& - (cref(j,k,1),j=1,3),k=1,nres) - endif - roznica=dsqrt(dabs(roznica)) - iresult = 1 - if (roznica.lt.rms_d) iresult = 0 -#else - energyy=enetbss(i) -!el call cmprs(x,x1,roznica,energyx,energyy,iresult) -#endif - if (iprint.gt.1) write(iout,'(i5,f10.6,$)') i,roznica -! print '(i5,f8.3)',i,roznica - if(iresult.eq.0) then - nlist = nlist + 1 - list(nlist)=i - if (iprint.gt.1) write(iout,*) - if(energyx.ge.enetbss(i)) then - if (iprint.gt.1) & - write(iout,*)'s*>> structure rejected - same as nr ',i, & - ' RMS',roznica - minimize_s_flag=0 - icomp=0 - go to 1106 - endif - endif - if(energyx.lt.enetbss(i).and.enex_jp.lt.enetbss(i))then - j=i - enex_jp=enetbss(i) - endif - enddo - if (iprint.gt.1) write(iout,*) - if(nlist.gt.0) then - if (modif) then - if (iprint.gt.1) & - write(iout,'(a,i3,$)')'s*>> structure accepted1 - repl nr ',& - list(1) - else - if (iprint.gt.1) & - write(iout,'(a,i3)') & - 's*>> structure accepted1 - would repl nr ',list(1) - endif - icomp=9 - if (.not. modif) goto 1106 - j=list(1) - enetbss(j)=energyx - do i=1,nvar - coordss(i,j)=x(i) - enddo - do j=2,nlist - if (iprint.gt.1) write(iout,'(i3,$)')list(j) - do kk=list(j)+1,nlist - enetbss(kk-1)=enetbss(kk) - do i=1,nvar - coordss(i,kk-1)=coordss(i,kk) - enddo - enddo - enddo - if (iprint.gt.1) write(iout,*) - go to 1106 - endif - if(n_thr.lt.num_thread_save) then - icomp=1 - if (modif) then - if (iprint.gt.1) & - write(iout,*)'s*>> structure accepted - add with nr ',n_thr+1 - else - if (iprint.gt.1) & - write(iout,*)'s*>> structure accepted - would add with nr ',& - n_thr+1 - goto 1106 - endif - n_thr=n_thr+1 - enetbss(n_thr)=energyx - do i=1,nvar - coordss(i,n_thr)=x(i) - enddo - else - if(j.eq.0) then - if (iprint.gt.1) & - write(iout,*)'s*>> structure rejected - too high energy' - icomp=2 - go to 1106 - end if - icomp=3 - if (modif) then - if (iprint.gt.1) & - write(iout,*)'s*>> structure accepted - repl nr ',j - else - if (iprint.gt.1) & - write(iout,*)'s*>> structure accepted - would repl nr ',j - goto 1106 - endif - enetbss(j)=energyx - do i=1,nvar - coordss(i,j)=x(i) - enddo - end if - -1106 continue - return - end subroutine compare_s1 -!----------------------------------------------------------------------------- -! entmcm.F -!----------------------------------------------------------------------------- - subroutine entmcm - - use energy_data - use geometry_data - use MPI_data, only:WhatsUp,MyID - use compare_data, only: ener - use control_data, only: minim,refstr - use io_base - use regularize_, only:fitsq - use control, only: tcpu,ovrtim - use compare - use minimm, only:minimize -! Does modified entropic sampling in the space of minima. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -#ifdef MPL - use MPI_data !include 'COMMON.INFO' -#endif -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.CONTACTS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.THREAD' -! include 'COMMON.NAMES' - logical :: accepted,not_done,over,error,lprint !,ovrtim - integer :: MoveType,nbond -! integer :: conf_comp - real(kind=8) :: RandOrPert - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - real(kind=8) :: elowest,ehighest,eold - real(kind=8) :: przes(3),obr(3,3) - real(kind=8),dimension(6*nres) :: varold !(maxvar) (maxvar=6*maxres) - logical :: non_conv - real(kind=8),dimension(0:n_ene) :: energia,energia_ave - -!!! local variables -el - integer :: i,ii,kkk,it,j,nacc,nfun,ijunk,indmin,indmax,& - ISWEEP,Kwita,iretcode,indeold,iene,noverlap,& - irep,nstart_grow,inde - real(kind=8) :: facee,conste,ejunk,etot,rms,co,frac,& - deix,dent,sold,scur,runtime -! - -! if(.not.allocated(varsave)) allocate(varsave(maxvar,maxsave)) !(maxvar,maxsave) -!d write (iout,*) 'print_mc=',print_mc - WhatsUp=0 - maxtrial_iter=50 -!--------------------------------------------------------------------------- -! Initialize counters. -!--------------------------------------------------------------------------- -! Total number of generated confs. - ngen=0 -! Total number of moves. In general this won't be equal to the number of -! attempted moves, because we may want to reject some "bad" confs just by -! overlap check. - nmove=0 -! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -! motions. -!el allocate(nbond_move(nres)) !(maxres) - - do i=1,nres - nbond_move(i)=0 - enddo -! Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -! Total number of energy evaluations. - neneval=0 - nfun=0 - indminn=-max_ene - indmaxx=max_ene - delte=0.5D0 - facee=1.0D0/(maxacc*delte) - conste=dlog(facee) -! Read entropy from previous simulations. - if (ent_read) then - read (ientin,*) indminn,indmaxx,emin,emax - print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin,& - ' emax=',emax - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) - indmin=indminn - indmax=indmaxx - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& - ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -! Read the pool of conformations - call read_pool -!---------------------------------------------------------------------------- -! Entropy-sampling simulations with continually updated entropy -! Loop thru simulations -!---------------------------------------------------------------------------- - DO ISWEEP=1,NSWEEP -!---------------------------------------------------------------------------- -! Take a conformation from the pool -!---------------------------------------------------------------------------- - if (npool.gt.0) then - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Took conformation',ii,' from the pool energy=',& - epool(ii) - call var_to_geom(nvar,varia) -! Print internal coordinates of the initial conformation - call intout - else - call gen_rand_conf(1,*20) - endif -!---------------------------------------------------------------------------- -! Compute and print initial energies. -!---------------------------------------------------------------------------- - nsave=0 -#ifdef MPL - allocate(nsave_part(nctasks)) - if (MyID.eq.MasterID) then - do i=1,nctasks - nsave_part(i)=0 - enddo - endif -#endif - Kwita=0 - WhatsUp=0 - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - call etotal(energia) - etot = energia(0) - call enerprint(energia) -! Minimize the energy of the first conformation. - if (minim) then - call geom_to_var(nvar,varia) - call minimize(etot,varia,iretcode,nfun) - call etotal(energia) - etot = energia(0) - write (iout,'(/80(1h*)/a/80(1h*))') & - 'Results of the first energy minimization:' - call enerprint(energia) - endif - if (refstr) then - kkk=1 - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk),& - nsup,przes,& - obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order:',co - write (istat,'(i5,11(1pe14.5))') 0,& - (energia(print_order(i)),i=1,nprint_ene),etot,rms,frac,co - else - write (istat,'(i5,9(1pe14.5))') 0,& - (energia(print_order(i)),i=1,nprint_ene),etot - endif - close(istat) - neneval=neneval+nfun+1 - if (.not. ent_read) then -! Initialize the entropy array - do i=-max_ene,max_ene - emin=etot -! Uncomment the line below for actual entropic sampling (start with uniform -! energy distribution). -! entropy(i)=0.0D0 -! Uncomment the line below for multicanonical sampling (start with Boltzmann -! distribution). - entropy(i)=(emin+i*delte)*betbol - enddo - emax=10000000.0D0 - emin=etot - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -#ifdef MPL - call recv_stop_sig(Kwita) - if (whatsup.eq.1) then - call send_stop_sig(-2) - not_done=.false. - else if (whatsup.le.-2) then - not_done=.false. - else if (whatsup.eq.2) then - not_done=.false. - else - not_done=.true. - endif -#else - not_done = (iretcode.ne.11) -#endif - write (iout,'(/80(1h*)/20x,a/80(1h*))') & - 'Enter Monte Carlo procedure.' - close(igeom) - call briefout(0,etot) - do i=1,nvar - varold(i)=varia(i) - enddo - eold=etot - indeold=(eold-emin)/delte - deix=eold-(emin+indeold*delte) - dent=entropy(indeold+1)-entropy(indeold) -!d write (iout,*) 'indeold=',indeold,' deix=',deix,' dent=',dent -!d write (*,*) 'Processor',MyID,' indeold=',indeold,' deix=',deix, -!d & ' dent=',dent - sold=entropy(indeold)+(dent/delte)*deix - elowest=etot - write (iout,*) 'eold=',eold,' sold=',sold,' elowest=',etot - write (*,*) 'Processor',MyID,' eold=',eold,' sold=',sold,& - ' elowest=',etot - if (minim) call zapis(varia,etot) - nminima(1)=1.0D0 -! NACC is the counter for the accepted conformations of a given processor - nacc=0 -! NACC_TOT counts the total number of accepted conformations - nacc_tot=0 -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - else - call send_MCM_info(2) - endif -#endif - do iene=indminn,indmaxx - nhist(iene)=0.0D0 - enddo - do i=2,maxsave - nminima(i)=0.0D0 - enddo -! Main loop. -!---------------------------------------------------------------------------- - elowest=1.0D10 - ehighest=-1.0D10 - it=0 - do while (not_done) - it=it+1 - if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') & - 'Beginning iteration #',it -! Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) - ntrial=ntrial+1 -! Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo -!d write (iout,'(a)') 'Old variables:' -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - call var_to_geom(nvar,varia) -! Rebuild the chain. - call chainbuild - MoveType=0 - nbond=0 - lprint=.true. -! Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) & - write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& - MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) & - write (iout,'(2a,i3)') 'Random-generated conformation',& - ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) -!d write (iout,'(a)') 'New variables:' -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - if (print_mc.gt.0) write (iout,'(a,i5,a,i10,a,i10)') & - 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - if (print_mc.gt.0) write (*,'(a,i5,a,i10,a,i10)') & - 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - call etotal(energia) - etot = energia(0) -! call enerprint(energia(0)) -! write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest - if (etot-elowest.gt.overlap_cut) then - write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it,& - ' Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else - if (minim) then - call minimize(etot,varia,iretcode,nfun) -!d write (iout,'(a)') 'Variables after minimization:' -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - call etotal(energia) - etot = energia(0) - neneval=neneval+nfun+1 - endif - if (print_mc.gt.2) then - write (iout,'(a)') 'Total energies of trial conf:' - call enerprint(energia) - else if (print_mc.eq.1) then - write (iout,'(a,i6,a,1pe16.6)') & - 'Trial conformation:',ngen,' energy:',etot - endif -!-------------------------------------------------------------------------- -!... Acceptance test -!-------------------------------------------------------------------------- - accepted=.false. - if (WhatsUp.eq.0) & - call accepting(etot,eold,scur,sold,varia,varold,& - accepted) - if (accepted) then - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - if (ehighest.lt.etot) ehighest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -! Check against conformation repetitions. - irep=conf_comp(varia,etot) -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - if (refstr) then - kkk=1 - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk),& - nsup,& - przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - if (print_mc.gt.0) & - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order:',co - if (print_stat) & - write (istat,'(i5,11(1pe14.5))') it,& - (energia(print_order(i)),i=1,nprint_ene),etot,& - rms,frac,co - elseif (print_stat) then - write (istat,'(i5,10(1pe14.5))') it,& - (energia(print_order(i)),i=1,nprint_ene),etot - endif - close(istat) - if (print_mc.gt.1) & - call statprint(nacc,nfun,iretcode,etot,elowest) -! Print internal coordinates. - if (print_int) call briefout(nacc,etot) -#ifdef MPL - if (MyID.ne.MasterID) then - call recv_stop_sig(Kwita) -!d print *,'Processor:',MyID,' STOP=',Kwita - if (irep.eq.0) then - call send_MCM_info(2) - else - call send_MCM_info(1) - endif - endif -#endif -! Store the accepted conf. and its energy. - eold=etot - sold=scur - do i=1,nvar - varold(i)=varia(i) - enddo - if (irep.eq.0) then - irep=nsave+1 -!d write (iout,*) 'Accepted conformation:' -!d write (iout,*) (rad2deg*varia(i),i=1,nphi) - if (minim) call zapis(varia,etot) - do i=1,n_ene - ener(i,nsave)=energia(i) - enddo - ener(n_ene+1,nsave)=etot - ener(n_ene+2,nsave)=frac - endif - nminima(irep)=nminima(irep)+1.0D0 -! print *,'irep=',irep,' nminima=',nminima(irep) -#ifdef MPL - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - endif ! accepted - endif ! overlap -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - if (nacc_tot.ge.maxacc) accepted=.true. - endif -#endif - if (ntrial.gt.maxtrial_iter .and. npool.gt.0) then -! Take a conformation from the pool - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Iteration',it,' max. # of trials exceeded.' - write (iout,*) & - 'Take conformation',ii,' from the pool energy=',epool(ii) - if (print_mc.gt.2) & - write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) - ntrial=0 - endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) - 30 continue - enddo ! accepted -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - endif - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - if (ovrtim()) WhatsUp=-1 -!d write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) & - .and. (Kwita.eq.0) -!d write (iout,*) 'not_done=',not_done -#ifdef MPL - if (Kwita.lt.0) then - print *,'Processor',MyID,& - ' has received STOP signal =',Kwita,' in EntSamp.' -!d print *,'not_done=',not_done - if (Kwita.lt.-1) WhatsUp=Kwita - else if (nacc_tot.ge.maxacc) then - print *,'Processor',MyID,' calls send_stop_sig,',& - ' because a sufficient # of confs. have been collected.' -!d print *,'not_done=',not_done - call send_stop_sig(-1) - else if (WhatsUp.eq.-1) then - print *,'Processor',MyID,& - ' calls send_stop_sig because of timeout.' -!d print *,'not_done=',not_done - call send_stop_sig(-2) - endif -#endif - enddo ! not_done - -!----------------------------------------------------------------- -!... Construct energy histogram & update entropy -!----------------------------------------------------------------- - go to 21 - 20 WhatsUp=-3 -#ifdef MPL - write (iout,*) 'Processor',MyID,& - ' is broadcasting ERROR-STOP signal.' - write (*,*) 'Processor',MyID,& - ' is broadcasting ERROR-STOP signal.' - call send_stop_sig(-3) -#endif - 21 continue -#ifdef MPL - if (MyID.eq.MasterID) then -! call receive_MCM_results - call receive_energies -#endif - do i=1,nsave - if (esave(i).lt.elowest) elowest=esave(i) - if (esave(i).gt.ehighest) ehighest=esave(i) - enddo - write (iout,'(a,i10)') '# of accepted confs:',nacc_tot - write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest,& - ' Highest energy',ehighest - if (isweep.eq.1 .and. .not.ent_read) then - emin=elowest - emax=ehighest - write (iout,*) 'EMAX=',emax - indminn=0 - indmaxx=(ehighest-emin)/delte - indmin=indminn - indmax=indmaxx - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - ent_read=.true. - else - indmin=(elowest-emin)/delte - indmax=(ehighest-emin)/delte - if (indmin.lt.indminn) indminn=indmin - if (indmax.gt.indmaxx) indmaxx=indmax - endif - write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx -! Construct energy histogram - do i=1,nsave - inde=(esave(i)-emin)/delte - nhist(inde)=nhist(inde)+nminima(i) - enddo -! Update entropy (density of states) - do i=indmin,indmax - if (nhist(i).gt.0) then - entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) - endif - enddo -!d do i=indmaxx+1 -!d entropy(i)=1.0D+10 -!d enddo - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') & - 'End of macroiteration',isweep - write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest,& - ' Ehighest=',ehighest - write (iout,'(a)') 'Frequecies of minima' - do i=1,nsave - write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) - enddo - write (iout,'(/a)') 'Energy histogram' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,nhist(i) - enddo - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo -!----------------------------------------------------------------- -!... End of energy histogram construction -!----------------------------------------------------------------- -#ifdef MPL - entropy(-max_ene-4)=dfloat(indminn) - entropy(-max_ene-3)=dfloat(indmaxx) - entropy(-max_ene-2)=emin - entropy(-max_ene-1)=emax - call send_MCM_update -!d print *,entname,ientout - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) - else - write (iout,'(a)') 'Frequecies of minima' - do i=1,nsave - write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) - enddo -! call send_MCM_results - call send_energies - call receive_MCM_update - indminn=entropy(-max_ene-4) - indmaxx=entropy(-max_ene-3) - emin=entropy(-max_ene-2) - emax=entropy(-max_ene-1) - write (iout,*) 'Received from master:' - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& - ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif - if (WhatsUp.lt.-1) return -#else - if (ovrtim() .or. WhatsUp.lt.0) return -#endif - - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') & - 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) -!el write (iout,'(a,i10)') 'Number of chain regrowths:',nregrow -!el write (iout,'(a,i10)') 'Accepted chain regrowths:',nregrow_acc - -!--------------------------------------------------------------------------- - ENDDO ! ISWEEP -!--------------------------------------------------------------------------- - - runtime=tcpu() - - if (isweep.eq.nsweep .and. it.ge.maxacc) & - write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - return - end subroutine entmcm -!----------------------------------------------------------------------------- - subroutine accepting(ecur,eold,scur,sold,x,xold,accepted) - - use geometry_data, only: nphi - use energy_data, only: max_ene -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -#ifdef MPL - use MPI_data !include 'COMMON.INFO' -#endif -! include 'COMMON.GEO' - real(kind=8) :: ecur,eold,xx,bol !,ran_number - real(kind=8),dimension(6*nres) :: x,xold !(maxvar) (maxvar=6*maxres) - real(kind=8) :: tole=1.0D-1, tola=5.0D0 - logical :: accepted - -!!! local variables - el - integer :: indecur - real(kind=8) :: scur,sold,xxh,deix,dent - -! Check if the conformation is similar. -!d write (iout,*) 'Enter ACCEPTING' -!d write (iout,*) 'Old PHI angles:' -!d write (iout,*) (rad2deg*xold(i),i=1,nphi) -!d write (iout,*) 'Current angles' -!d write (iout,*) (rad2deg*x(i),i=1,nphi) -!d ddif=dif_ang(nphi,x,xold) -!d write (iout,*) 'Angle norm:',ddif -!d write (iout,*) 'ecur=',ecur,' emax=',emax - if (ecur.gt.emax) then - accepted=.false. - if (print_mc.gt.0) & - write (iout,'(a)') 'Conformation rejected as too high in energy' - return - else if (dabs(ecur-eold).lt.tole .and. & - dif_ang(nphi,x,xold).lt.tola) then - accepted=.false. - if (print_mc.gt.0) & - write (iout,'(a)') 'Conformation rejected as too similar' - return - endif -! Else evaluate the entropy of the conf and compare it with that of the previous -! one. - indecur=(ecur-emin)/delte - if (iabs(indecur).gt.max_ene) then - write (iout,'(a,2i5)') & - 'Accepting: Index out of range:',indecur - scur=1000.0D0 - else if (indecur.eq.indmaxx) then - scur=entropy(indecur) - if (print_mc.gt.0) write (iout,*)'Energy boundary reached',& - indmaxx,indecur,entropy(indecur) - else - deix=ecur-(emin+indecur*delte) - dent=entropy(indecur+1)-entropy(indecur) - scur=entropy(indecur)+(dent/delte)*deix - endif -!d print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, -!d & ' scur=',scur,' eold=',eold,' sold=',sold -!d print *,'deix=',deix,' dent=',dent,' delte=',delte - if (print_mc.gt.1) then - write(iout,*)'ecur=',ecur,' indecur=',indecur,' scur=',scur - write(iout,*)'eold=',eold,' sold=',sold - endif - if (scur.le.sold) then - accepted=.true. - else -! Else carry out acceptance test - xx=ran_number(0.0D0,1.0D0) - xxh=scur-sold - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (bol.gt.xx) then - accepted=.true. - if (print_mc.gt.0) write (iout,'(a)') & - 'Conformation accepted.' - else - accepted=.false. - if (print_mc.gt.0) write (iout,'(a)') & - 'Conformation rejected.' - endif - endif - return - end subroutine accepting -!----------------------------------------------------------------------------- - subroutine read_pool - - use io_base, only:read_angles -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.VAR' - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - -!!! local variables - el - integer :: j,i,iconf - - print '(a)','Call READ_POOL' - do npool=1,max_pool - print *,'i=',i - read (intin,'(i5,f10.5)',end=10,err=10) iconf,epool(npool) - if (epool(npool).eq.0.0D0) goto 10 - call read_angles(intin,*10) - call geom_to_var(nvar,xpool(1,npool)) - enddo - goto 11 - 10 npool=npool-1 - 11 write (iout,'(a,i5)') 'Number of pool conformations:',npool - if (print_mc.gt.2) then - do i=1,npool - write (iout,'(a,i5,a,1pe14.5)') 'Pool conformation',i,' energy',& - epool(i) - write (iout,'(10f8.3)') (rad2deg*xpool(j,i),j=1,nvar) - enddo - endif ! (print_mc.gt.2) - return - end subroutine read_pool -!----------------------------------------------------------------------------- -! mc.F -!----------------------------------------------------------------------------- - subroutine monte_carlo - - use energy_data - use geometry_data - use MPI_data, only:ifinish,nctasks,WhatsUp,MyID - use control_data, only:refstr,MaxProcs - use io_base - use control, only:tcpu,ovrtim - use regularize_, only:fitsq - use compare -! use control -! Does Boltzmann and entropic sampling without energy minimization -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -#ifdef MPL - use MPI_data !include 'COMMON.INFO' -#endif -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.CONTACTS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.THREAD' -! include 'COMMON.NAMES' - logical :: accepted,not_done,over,error,lprint !,ovrtim - integer :: MoveType,nbond,nbins -! integer :: conf_comp - real(kind=8) :: RandOrPert - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - real(kind=8) :: elowest,elowest1,ehighest,ehighest1,eold - real(kind=8) :: przes(3),obr(3,3) - real(kind=8),dimension(6*nres) :: varold !(maxvar) (maxvar=6*maxres) - logical :: non_conv - integer,dimension(-1:MaxMoveType+1,0:MaxProcs-1) :: moves1,moves_acc1 !(-1:MaxMoveType+1,0:MaxProcs-1) -#ifdef MPL - real(kind=8) :: etot_temp,etot_all(0:MaxProcs) - external d_vadd,d_vmin,d_vmax - real(kind=8),dimension(-max_ene:max_ene) :: entropy1,nhist1 - integer,dimension(nres*(MaxProcs+1)) :: nbond_move1,nbond_acc1 - integer,dimension(2) :: itemp -#endif - real(kind=8),dimension(6*nres) :: var_lowest !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(0:n_ene) :: energia,energia_ave -! -!!! local variables - el - integer :: i,j,it,ii,iproc,nacc,ISWEEP,nfun,indmax,indmin,ijunk,& - Kwita,indeold,imdmax,inde,iretcode,nstart_grow,noverlap - real(kind=8) :: facee,conste,ejunk,etot,sold,frac,runtime,& - frac_ave,rms_ave,etot_ave,scur,from_pool,co,rms - - write(iout,'(a,i8,2x,a,f10.5)') & - 'pool_read_freq=',pool_read_freq,' pool_fraction=',pool_fraction - open (istat,file=statname) - WhatsUp=0 - indminn=-max_ene - indmaxx=max_ene - facee=1.0D0/(maxacc*delte) -! Number of bins in energy histogram - nbins=e_up/delte-1 - write (iout,*) 'NBINS=',nbins - conste=dlog(facee) -! Read entropy from previous simulations. - if (ent_read) then - read (ientin,*) indminn,indmaxx,emin,emax - print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin,& - ' emax=',emax - do i=-max_ene,max_ene - entropy(i)=0.0D0 - enddo - read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) - indmin=indminn - indmax=indmaxx - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& - ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -! Read the pool of conformations - call read_pool - elowest=1.0D+10 - ehighest=-1.0D+10 -!---------------------------------------------------------------------------- -! Entropy-sampling simulations with continually updated entropy; -! set NSWEEP=1 for Boltzmann sampling. -! Loop thru simulations -!---------------------------------------------------------------------------- - allocate(ifinish(nctasks)) - DO ISWEEP=1,NSWEEP -! -! Initialize the IFINISH array. -! -#ifdef MPL - do i=1,nctasks - ifinish(i)=0 - enddo -#endif -!--------------------------------------------------------------------------- -! Initialize counters. -!--------------------------------------------------------------------------- -! Total number of generated confs. - ngen=0 -! Total number of moves. In general this won't be equal to the number of -! attempted moves, because we may want to reject some "bad" confs just by -! overlap check. - nmove=0 -! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -! motions. -!el allocate(nbond_move(nres)) !(maxres) -!el allocate(nbond_acc(nres)) !(maxres) - - do i=1,nres - nbond_move(i)=0 - nbond_acc(i)=0 - enddo -! Initialize total and accepted number of moves of various kind. - do i=-1,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -! Total number of energy evaluations. - neneval=0 - nfun=0 -!---------------------------------------------------------------------------- -! Take a conformation from the pool -!---------------------------------------------------------------------------- - rewind(istat) - write (iout,*) 'emin=',emin,' emax=',emax - if (npool.gt.0) then - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Took conformation',ii,' from the pool energy=',& - epool(ii) - call var_to_geom(nvar,varia) -! Print internal coordinates of the initial conformation - call intout - else if (isweep.gt.1) then - if (eold.lt.emax) then - do i=1,nvar - varia(i)=varold(i) - enddo - else - do i=1,nvar - varia(i)=var_lowest(i) - enddo - endif - call var_to_geom(nvar,varia) - endif -!---------------------------------------------------------------------------- -! Compute and print initial energies. -!---------------------------------------------------------------------------- - nsave=0 - Kwita=0 - WhatsUp=0 - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - call geom_to_var(nvar,varia) - call etotal(energia) - etot = energia(0) - call enerprint(energia) - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),nsup,przes,& - obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order',co - write (istat,'(i10,16(1pe14.5))') 0,& - (energia(print_order(i)),i=1,nprint_ene),& - etot,rms,frac,co - else - write (istat,'(i10,14(1pe14.5))') 0,& - (energia(print_order(i)),i=1,nprint_ene),etot - endif -! close(istat) - neneval=neneval+1 - if (.not. ent_read) then -! Initialize the entropy array -#ifdef MPL -! Collect total energies from other processors. - etot_temp=etot - etot_all(0)=etot - call mp_gather(etot_temp,etot_all,8,MasterID,cgGroupID) - if (MyID.eq.MasterID) then -! Get the lowest and the highest energy. - print *,'MASTER: etot_temp: ',(etot_all(i),i=0,nprocs-1),& - ' emin=',emin,' emax=',emax - emin=1.0D10 - emax=-1.0D10 - do i=0,nprocs - if (emin.gt.etot_all(i)) emin=etot_all(i) - if (emax.lt.etot_all(i)) emax=etot_all(i) - enddo - emax=emin+e_up - endif ! MyID.eq.MasterID - etot_all(1)=emin - etot_all(2)=emax - print *,'Processor',MyID,' calls MP_BCAST to send/recv etot_all' - call mp_bcast(etot_all(1),16,MasterID,cgGroupID) - print *,'Processor',MyID,' MP_BCAST to send/recv etot_all ended' - if (MyID.ne.MasterID) then - print *,'Processor:',MyID,etot_all(1),etot_all(2),& - etot_all(1),etot_all(2) - emin=etot_all(1) - emax=etot_all(2) - endif ! MyID.ne.MasterID - write (iout,*) 'After MP_GATHER etot_temp=',& - etot_temp,' emin=',emin -#else - emin=etot - emax=emin+e_up - indminn=0 - indmin=0 -#endif - IF (MULTICAN) THEN -! Multicanonical sampling - start from Boltzmann distribution - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - ELSE -! Entropic sampling - start from uniform distribution of the density of states - do i=-max_ene,max_ene - entropy(i)=0.0D0 - enddo - ENDIF ! MULTICAN - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - if (isweep.eq.1) then - emax=emin+e_up - indminn=0 - indmin=0 - indmaxx=indminn+nbins - indmax=indmaxx - endif ! isweep.eq.1 - endif ! .not. ent_read -#ifdef MPL - call recv_stop_sig(Kwita) - if (whatsup.eq.1) then - call send_stop_sig(-2) - not_done=.false. - else if (whatsup.le.-2) then - not_done=.false. - else if (whatsup.eq.2) then - not_done=.false. - else - not_done=.true. - endif -#else - not_done=.true. -#endif - write (iout,'(/80(1h*)/20x,a/80(1h*))') & - 'Enter Monte Carlo procedure.' - close(igeom) - call briefout(0,etot) - do i=1,nvar - varold(i)=varia(i) - enddo - eold=etot - call entropia(eold,sold,indeold) -! NACC is the counter for the accepted conformations of a given processor - nacc=0 -! NACC_TOT counts the total number of accepted conformations - nacc_tot=0 -! Main loop. -!---------------------------------------------------------------------------- -! Zero out average energies - do i=0,n_ene - energia_ave(i)=0.0d0 - enddo -! Initialize energy histogram - do i=-max_ene,max_ene - nhist(i)=0.0D0 - enddo ! i -! Zero out iteration counter. - it=0 - do j=1,nvar - varold(j)=varia(j) - enddo -! Begin MC iteration loop. - do while (not_done) - it=it+1 -! Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) - ntrial=ntrial+1 -! Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -! Rebuild the chain. - call chainbuild - MoveType=0 - nbond=0 - lprint=.true. -! Decide whether to take a conformation from the pool or generate/perturb one -! randomly - from_pool=ran_number(0.0D0,1.0D0) - if (npool.gt.0 .and. from_pool.lt.pool_fraction) then -! Throw a dice to choose the conformation from the pool - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - call var_to_geom(nvar,varia) - call chainbuild -!d call intout -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a,i3,a,f10.5)') & - 'Try conformation',ii,' from the pool energy=',epool(ii) - MoveType=-1 - moves(-1)=moves(-1)+1 - else -! Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,0.1D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& - MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(2a,i3)') 'Random-generated conformation',& - ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) - endif ! pool -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a,i5,a,i10,a,i10)') & - 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (*,'(a,i5,a,i10,a,i10)') & - 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - call etotal(energia) - etot = energia(0) - neneval=neneval+1 -!d call enerprint(energia(0)) -!d write(iout,*)'it=',it,' etot=',etot - if (etot-elowest.gt.overlap_cut) then - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it,& - ' Overlap detected in the current conf.; energy is',etot - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else -!-------------------------------------------------------------------------- -!... Acceptance test -!-------------------------------------------------------------------------- - accepted=.false. - if (WhatsUp.eq.0) & - call accept_mc(it,etot,eold,scur,sold,varia,varold,accepted) - if (accepted) then - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) then - elowest=etot - do i=1,nvar - var_lowest(i)=varia(i) - enddo - endif - if (ehighest.lt.etot) ehighest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -! Compare with reference structure. - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),& - nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - endif ! refstr -! -! Periodically save average energies and confs. -! - do i=0,n_ene - energia_ave(i)=energia_ave(i)+energia(i) - enddo - moves(MaxMoveType+1)=nmove - moves_acc(MaxMoveType+1)=nacc - IF ((it/save_frequency)*save_frequency.eq.it) THEN - do i=0,n_ene - energia_ave(i)=energia_ave(i)/save_frequency - enddo - etot_ave=energia_ave(0) -!#ifdef AIX -! open (istat,file=statname,position='append') -!#else -! open (istat,file=statname,access='append') -!endif - if (print_mc.gt.0) & - write (iout,'(80(1h*)/20x,a,i20)') & - 'Iteration #',it - if (refstr .and. print_mc.gt.0) then - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order:',co - endif - if (print_stat) then - if (refstr) then - write (istat,'(i10,10(1pe14.5))') it,& - (energia_ave(print_order(i)),i=1,nprint_ene),& - etot_ave,rms_ave,frac_ave - else - write (istat,'(i10,10(1pe14.5))') it,& - (energia_ave(print_order(i)),i=1,nprint_ene),& - etot_ave - endif - endif -! close(istat) - if (print_mc.gt.0) & - call statprint(nacc,nfun,iretcode,etot,elowest) -! Print internal coordinates. - if (print_int) call briefout(nacc,etot) - do i=0,n_ene - energia_ave(i)=0.0d0 - enddo - ENDIF ! ( (it/save_frequency)*save_frequency.eq.it) -! Update histogram - inde=icialosc((etot-emin)/delte) - nhist(inde)=nhist(inde)+1.0D0 -#ifdef MPL - if ( (it/message_frequency)*message_frequency.eq.it & - .and. (MyID.ne.MasterID) ) then - call recv_stop_sig(Kwita) - call send_MCM_info(message_frequency) - endif -#endif -! Store the accepted conf. and its energy. - eold=etot - sold=scur - do i=1,nvar - varold(i)=varia(i) - enddo -#ifdef MPL - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - endif ! accepted - endif ! overlap -#ifdef MPL - if (MyID.eq.MasterID .and. & - (it/message_frequency)*message_frequency.eq.it) then - call receive_MC_info - if (nacc_tot.ge.maxacc) accepted=.true. - endif -#endif -! if ((ntrial.gt.maxtrial_iter -! & .or. (it/pool_read_freq)*pool_read_freq.eq.it) -! & .and. npool.gt.0) then -! Take a conformation from the pool -! ii=iran_num(1,npool) -! do i=1,nvar -! varold(i)=xpool(i,ii) -! enddo -! if (ntrial.gt.maxtrial_iter) -! & write (iout,*) 'Iteration',it,' max. # of trials exceeded.' -! write (iout,*) -! & 'Take conformation',ii,' from the pool energy=',epool(ii) -! if (print_mc.gt.2) -! & write (iout,'(10f8.3)') (rad2deg*varold(i),i=1,nvar) -! ntrial=0 -! eold=epool(ii) -! call entropia(eold,sold,indeold) -! accepted=.true. -! endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) - 30 continue - enddo ! accepted -#ifdef MPL - if (MyID.eq.MasterID .and. & - (it/message_frequency)*message_frequency.eq.it) then - call receive_MC_info - endif - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - if (ovrtim()) WhatsUp=-1 -!d write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) & - .and. (Kwita.eq.0) -!d write (iout,*) 'not_done=',not_done -#ifdef MPL - if (Kwita.lt.0) then - print *,'Processor',MyID,& - ' has received STOP signal =',Kwita,' in EntSamp.' -!d print *,'not_done=',not_done - if (Kwita.lt.-1) WhatsUp=Kwita - if (MyID.ne.MasterID) call send_MCM_info(-1) - else if (nacc_tot.ge.maxacc) then - print *,'Processor',MyID,' calls send_stop_sig,',& - ' because a sufficient # of confs. have been collected.' -!d print *,'not_done=',not_done - call send_stop_sig(-1) - if (MyID.ne.MasterID) call send_MCM_info(-1) - else if (WhatsUp.eq.-1) then - print *,'Processor',MyID,& - ' calls send_stop_sig because of timeout.' -!d print *,'not_done=',not_done - call send_stop_sig(-2) - if (MyID.ne.MasterID) call send_MCM_info(-1) - endif -#endif - enddo ! not_done - -!----------------------------------------------------------------- -!... Construct energy histogram & update entropy -!----------------------------------------------------------------- - go to 21 - 20 WhatsUp=-3 -#ifdef MPL - write (iout,*) 'Processor',MyID,& - ' is broadcasting ERROR-STOP signal.' - write (*,*) 'Processor',MyID,& - ' is broadcasting ERROR-STOP signal.' - call send_stop_sig(-3) - if (MyID.ne.MasterID) call send_MCM_info(-1) -#endif - 21 continue - write (iout,'(/a)') 'Energy histogram' - do i=-100,100 - write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) - enddo -#ifdef MPL -! Wait until every processor has sent complete MC info. - if (MyID.eq.MasterID) then - not_done=.true. - do while (not_done) -! write (*,*) 'The IFINISH array:' -! write (*,*) (ifinish(i),i=1,nctasks) - not_done=.false. - do i=2,nctasks - not_done=not_done.or.(ifinish(i).ge.0) - enddo - if (not_done) call receive_MC_info - enddo - endif -! Make collective histogram from the work of all processors. - msglen=(2*max_ene+1)*8 - print *,& - 'Processor',MyID,' calls MP_REDUCE to send/receive histograms',& - ' msglen=',msglen - call mp_reduce(nhist,nhist1,msglen,MasterID,d_vadd,& - cgGroupID) - print *,'Processor',MyID,' MP_REDUCE accomplished for histogr.' - do i=-max_ene,max_ene - nhist(i)=nhist1(i) - enddo -! Collect min. and max. energy - print *, & - 'Processor',MyID,' calls MP_REDUCE to send/receive energy borders' - call mp_reduce(elowest,elowest1,8,MasterID,d_vmin,cgGroupID) - call mp_reduce(ehighest,ehighest1,8,MasterID,d_vmax,cgGroupID) - print *,'Processor',MyID,' MP_REDUCE accomplished for energies.' - IF (MyID.eq.MasterID) THEN - elowest=elowest1 - ehighest=ehighest1 -#endif - write (iout,'(a,i10)') '# of accepted confs:',nacc_tot - write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest,& - ' Highest energy',ehighest - indmin=icialosc((elowest-emin)/delte) - imdmax=icialosc((ehighest-emin)/delte) - if (indmin.lt.indminn) then - emax=emin+indmin*delte+e_up - indmaxx=indmin+nbins - indminn=indmin - endif - if (.not.ent_read) ent_read=.true. - write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx -! Update entropy (density of states) - do i=indmin,indmax - if (nhist(i).gt.0) then - entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) - endif - enddo - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') & - 'End of macroiteration',isweep - write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest,& - ' Ehighest=',ehighest - write (iout,'(/a)') 'Energy histogram' - do i=indminn,indmaxx - write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) - enddo - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f20.5)') i,emin+i*delte,entropy(i) - enddo -!----------------------------------------------------------------- -!... End of energy histogram construction -!----------------------------------------------------------------- -#ifdef MPL - ELSE - if (.not. ent_read) ent_read=.true. - ENDIF ! MyID .eq. MaterID - if (MyID.eq.MasterID) then - itemp(1)=indminn - itemp(2)=indmaxx - endif - print *,'before mp_bcast processor',MyID,' indminn=',indminn,& - ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) - call mp_bcast(itemp(1),8,MasterID,cgGroupID) - call mp_bcast(emax,8,MasterID,cgGroupID) - print *,'after mp_bcast processor',MyID,' indminn=',indminn,& - ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) - if (MyID .ne. MasterID) then - indminn=itemp(1) - indmaxx=itemp(2) - endif - msglen=(indmaxx-indminn+1)*8 - print *,'processor',MyID,' calling mp_bcast msglen=',msglen,& - ' indminn=',indminn,' indmaxx=',indmaxx,' isweep=',isweep - call mp_bcast(entropy(indminn),msglen,MasterID,cgGroupID) - IF(MyID.eq.MasterID .and. .not. ovrtim() .and. WhatsUp.ge.0)THEN - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) - ELSE - write (iout,*) 'Received from master:' - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,& - ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - ENDIF ! MyID.eq.MasterID - print *,'Processor',MyID,' calls MP_GATHER' - call mp_gather(nbond_move,nbond_move1,4*Nbm,MasterID,& - cgGroupID) - call mp_gather(nbond_acc,nbond_acc1,4*Nbm,MasterID,& - cgGroupID) - print *,'Processor',MyID,' MP_GATHER call accomplished' - if (MyID.eq.MasterID) then - - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc_tot,nfun,iretcode,etot,elowest) - write (iout,'(a)') & - 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) - - write (iout,'(a)') & - 'Statistics of multi-bond moves of respective processors:' - do iproc=1,Nprocs-1 - do i=1,Nbm - ind=iproc*nbm+i - nbond_move(i)=nbond_move(i)+nbond_move1(ind) - nbond_acc(i)=nbond_acc(i)+nbond_acc1(ind) - enddo - enddo - do iproc=0,NProcs-1 - write (iout,*) 'Processor',iproc,' nbond_move:', & - (nbond_move1(iproc*nbm+i),i=1,Nbm),& - ' nbond_acc:',(nbond_acc1(iproc*nbm+i),i=1,Nbm) - enddo - endif - call mp_gather(moves,moves1,4*(MaxMoveType+3),MasterID,& - cgGroupID) - call mp_gather(moves_acc,moves_acc1,4*(MaxMoveType+3),& - MasterID,cgGroupID) - if (MyID.eq.MasterID) then - do iproc=1,Nprocs-1 - do i=-1,MaxMoveType+1 - moves(i)=moves(i)+moves1(i,iproc) - moves_acc(i)=moves_acc(i)+moves_acc1(i,iproc) - enddo - enddo - nmove=0 - do i=0,MaxMoveType+1 - nmove=nmove+moves(i) - enddo - do iproc=0,NProcs-1 - write (iout,*) 'Processor',iproc,' moves',& - (moves1(i,iproc),i=0,MaxMoveType+1),& - ' moves_acc:',(moves_acc1(i,iproc),i=0,MaxMoveType+1) - enddo - endif -#else - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) -#endif - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc_tot,nfun,iretcode,etot,elowest) - write (iout,'(a)') & - 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) - if (ovrtim() .or. WhatsUp.lt.0) return - -!--------------------------------------------------------------------------- - ENDDO ! ISWEEP -!--------------------------------------------------------------------------- - - runtime=tcpu() - - if (isweep.eq.nsweep .and. it.ge.maxacc) & - write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - return - end subroutine monte_carlo -!----------------------------------------------------------------------------- - subroutine accept_mc(it,ecur,eold,scur,sold,x,xold,accepted) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -#ifdef MPL - use MPI_data !include 'COMMON.INFO' -#endif -! include 'COMMON.GEO' - real(kind=8) :: ecur,eold,xx,bol - real(kind=8),dimension(6*nres) :: x,xold !(maxvar) (maxvar=6*maxres) - logical :: accepted - -!el local variables - integer :: it,indecur - real(kind=8) :: scur,sold,xxh -! Check if the conformation is similar. -!d write (iout,*) 'Enter ACCEPTING' -!d write (iout,*) 'Old PHI angles:' -!d write (iout,*) (rad2deg*xold(i),i=1,nphi) -!d write (iout,*) 'Current angles' -!d write (iout,*) (rad2deg*x(i),i=1,nphi) -!d ddif=dif_ang(nphi,x,xold) -!d write (iout,*) 'Angle norm:',ddif -!d write (iout,*) 'ecur=',ecur,' emax=',emax - if (ecur.gt.emax) then - accepted=.false. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a)') 'Conformation rejected as too high in energy' - return - endif -! Else evaluate the entropy of the conf and compare it with that of the previous -! one. - call entropia(ecur,scur,indecur) -!d print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, -!d & ' scur=',scur,' eold=',eold,' sold=',sold -!d print *,'deix=',deix,' dent=',dent,' delte=',delte - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) then - write(iout,*)'it=',it,'ecur=',ecur,' indecur=',indecur,& - ' scur=',scur - write(iout,*)'eold=',eold,' sold=',sold - endif - if (scur.le.sold) then - accepted=.true. - else -! Else carry out acceptance test - xx=ran_number(0.0D0,1.0D0) - xxh=scur-sold - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (bol.gt.xx) then - accepted=.true. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a)') 'Conformation accepted.' - else - accepted=.false. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) & - write (iout,'(a)') 'Conformation rejected.' - endif - endif - return - end subroutine accept_mc -!----------------------------------------------------------------------------- - integer function icialosc(x) - - real(kind=8) :: x - if (x.lt.0.0D0) then - icialosc=dint(x)-1 - else - icialosc=dint(x) - endif - return - end function icialosc -!----------------------------------------------------------------------------- - subroutine entropia(ecur,scur,indecur) - - use energy_data, only: max_ene -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.IOUNITS' - real(kind=8) :: ecur,scur,deix,dent - integer :: indecur,it !???el - - indecur=icialosc((ecur-emin)/delte) - if (iabs(indecur).gt.max_ene) then - if ((it/print_freq)*it.eq.it) write (iout,'(a,2i5)') & - 'Accepting: Index out of range:',indecur - scur=1000.0D0 - else if (indecur.ge.indmaxx) then - scur=entropy(indecur) - if (print_mc.gt.0 .and. (it/print_freq)*it.eq.it) & - write (iout,*)'Energy boundary reached',& - indmaxx,indecur,entropy(indecur) - else - deix=ecur-(emin+indecur*delte) - dent=entropy(indecur+1)-entropy(indecur) - scur=entropy(indecur)+(dent/delte)*deix - endif - return - end subroutine entropia -!----------------------------------------------------------------------------- -! mcm.F -!----------------------------------------------------------------------------- - subroutine mcm_setup - - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.MCM' -! include 'COMMON.CONTROL' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! -!!! local variables - el - integer :: i,i1,i2,it1,it2,ngly,mmm,maxwinlen - -! Set up variables used in MC/MCM. -! -! allocate(sumpro_bond(0:nres)) !(0:maxres) - - write (iout,'(80(1h*)/20x,a/80(1h*))') 'MCM control parameters:' - write (iout,'(5(a,i7))') 'Maxacc:',maxacc,' MaxTrial:',MaxTrial,& - ' MaxRepm:',MaxRepm,' MaxGen:',MaxGen,' MaxOverlap:',MaxOverlap - write (iout,'(4(a,f8.1)/2(a,i3))') & - 'Tmin:',Tmin,' Tmax:',Tmax,' TstepH:',TstepH,& - ' TstepC:',TstepC,'NstepH:',NstepH,' NstepC:',NstepC - if (nwindow.gt.0) then - write (iout,'(a)') 'Perturbation windows:' - do i=1,nwindow - i1=winstart(i) - i2=winend(i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(a,i3,a,i3,a,i3)') restyp(it1),i1,restyp(it2),i2,& - ' length',winlen(i) - enddo - endif -! Rbolt=8.3143D-3*2.388459D-01 kcal/(mol*K) - RBol=1.9858D-3 -! Number of "end bonds". - koniecl=0 -! koniecl=nphi - print *,'koniecl=',koniecl - write (iout,'(a)') 'Probabilities of move types:' - write (*,'(a)') 'Probabilities of move types:' - do i=1,MaxMoveType - write (iout,'(a,f10.5)') MovTypID(i),& - sumpro_type(i)-sumpro_type(i-1) - write (*,'(a,f10.5)') MovTypID(i),& - sumpro_type(i)-sumpro_type(i-1) - enddo - write (iout,*) -! Maximum length of N-bond segment to be moved -! nbm=nres-1-(2*koniecl-1) - if (nwindow.gt.0) then - maxwinlen=winlen(1) - do i=2,nwindow - if (winlen(i).gt.maxwinlen) maxwinlen=winlen(i) - enddo - nbm=min0(maxwinlen,6) - write (iout,'(a,i3,a,i3)') 'Nbm=',Nbm,' Maxwinlen=',Maxwinlen - else - nbm=min0(6,nres-2) - endif - sumpro_bond(0)=0.0D0 - sumpro_bond(1)=0.0D0 - do i=2,nbm - sumpro_bond(i)=sumpro_bond(i-1)+1.0D0/dfloat(i) - enddo - write (iout,'(a)') 'The SumPro_Bond array:' - write (iout,'(8f10.5)') (sumpro_bond(i),i=1,nbm) - write (*,'(a)') 'The SumPro_Bond array:' - write (*,'(8f10.5)') (sumpro_bond(i),i=1,nbm) -! Maximum number of side chains moved simultaneously -! print *,'nnt=',nnt,' nct=',nct - ngly=0 - do i=nnt,nct - if (itype(i).eq.10) ngly=ngly+1 - enddo - mmm=nct-nnt-ngly+1 - if (mmm.gt.0) then - MaxSideMove=min0((nct-nnt+1)/2,mmm) - endif -! print *,'MaxSideMove=',MaxSideMove -! Max. number of generated confs (not used at present). - maxgen=10000 -! Set initial temperature - Tcur=Tmin - betbol=1.0D0/(Rbol*Tcur) - write (iout,'(a,f8.1,a,f10.5)') 'Initial temperature:',Tcur,& - ' BetBol:',betbol - write (iout,*) 'RanFract=',ranfract - return - end subroutine mcm_setup -!----------------------------------------------------------------------------- -#ifndef MPI - subroutine do_mcm(i_orig) - - use geometry_data - use energy_data - use MPI_data, only:Whatsup - use control_data, only:refstr,minim,iprint - use io_base - use control, only:tcpu,ovrtim - use regularize_, only:fitsq - use compare - use minimm, only:minimize -! Monte-Carlo-with-Minimization calculations - serial code. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.MCM' -! include 'COMMON.CONTACTS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.CACHE' -!rc include 'COMMON.DEFORM' -!rc include 'COMMON.DEFORM1' -! include 'COMMON.NAMES' - logical :: accepted,over,error,lprint,not_done,my_conf,& - enelower,non_conv !,ovrtim - integer :: MoveType,nbond !,conf_comp - integer,dimension(max_cache) :: ifeed - real(kind=8),dimension(6*nres) :: varia,varold !(maxvar) (maxvar=6*maxres) - real(kind=8) :: elowest,eold - real(kind=8) :: przes(3),obr(3,3) - real(kind=8) :: energia(0:n_ene) - real(kind=8) :: coord1(6*nres,max_thread2),enetb1(max_threadss) !el -!!! local variables - el - integer :: i,nf,nacc,it,nout,j,i_orig,nfun,Kwita,iretcode,& - noverlap,nstart_grow,irepet,n_thr,ii - real(kind=8) :: etot,frac,rms,co,RandOrPert,& - rms_deform,runtime -!--------------------------------------------------------------------------- -! Initialize counters. -!--------------------------------------------------------------------------- -! Total number of generated confs. - ngen=0 -! Total number of moves. In general this won't be equal to the number of -! attempted moves, because we may want to reject some "bad" confs just by -! overlap check. - nmove=0 -! Total number of temperature jumps. - ntherm=0 -! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -! motions. -! if(.not.allocated(varsave)) allocate(varsave(maxvar,maxsave)) !(maxvar,maxsave) -! allocate(nbond_move(nres)) !(maxres) - - ncache=0 - do i=1,nres - nbond_move(i)=0 - enddo -! Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -! Total number of energy evaluations. - neneval=0 - nfun=0 - nsave=0 - - write (iout,*) 'RanFract=',RanFract - - WhatsUp=0 - Kwita=0 - -!---------------------------------------------------------------------------- -! Compute and print initial energies. -!---------------------------------------------------------------------------- - call intout - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - nf=0 - - call etotal(energia) - etot = energia(0) -! Minimize the energy of the first conformation. - if (minim) then - call geom_to_var(nvar,varia) -! write (iout,*) 'The VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - call chainbuild - write (iout,*) 'etot from MINIMIZE:',etot -! write (iout,*) 'Tha VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - - call etotal(energia) - etot=energia(0) - call enerprint(energia) - endif - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),nsup,przes,& !el cref(1,nstart_sup) - obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order:',co - if (print_stat) & - write (istat,'(i5,17(1pe14.5))') 0,& - (energia(print_order(i)),i=1,nprint_ene),& - etot,rms,frac,co - else - if (print_stat) write (istat,'(i5,16(1pe14.5))') 0,& - (energia(print_order(i)),i=1,nprint_ene),etot - endif - if (print_stat) close(istat) - neneval=neneval+nfun+1 - write (iout,'(/80(1h*)/20x,a/80(1h*))') & - 'Enter Monte Carlo procedure.' - if (print_int) then - close(igeom) - call briefout(0,etot) - endif - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - elowest=etot - call zapis(varia,etot) - nacc=0 ! total # of accepted confs of the current processor. - nacc_tot=0 ! total # of accepted confs of all processors. - - not_done = (iretcode.ne.11) - -!---------------------------------------------------------------------------- -! Main loop. -!---------------------------------------------------------------------------- - it=0 - nout=0 - do while (not_done) - it=it+1 - write (iout,'(80(1h*)/20x,a,i7)') & - 'Beginning iteration #',it -! Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - accepted=.false. - do while (.not. accepted) - -! Retrieve the angles of previously accepted conformation - noverlap=0 ! # of overlapping confs. - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -! Rebuild the chain. - call chainbuild -! Heat up the system, if necessary. - call heat(over) -! If temperature cannot be further increased, stop. - if (over) goto 20 - MoveType=0 - nbond=0 - lprint=.true. -!d write (iout,'(a)') 'Old variables:' -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) -! Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) & - write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& - MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) & - write (iout,'(2a,i3)') 'Random-generated conformation',& - ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) -!d write (iout,'(a)') 'New variables:' -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - - call etotal(energia) - etot=energia(0) -! call enerprint(energia(0)) -! write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest - if (etot-elowest.gt.overlap_cut) then - if(iprint.gt.1.or.etot.lt.1d20) & - write (iout,'(a,1pe14.5)') & - 'Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else - if (minim) then - call minimize(etot,varia,iretcode,nfun) -!d write (iout,*) 'etot from MINIMIZE:',etot -!d write (iout,'(a)') 'Variables after minimization:' -!d write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - - call etotal(energia) - etot = energia(0) - neneval=neneval+nfun+2 - endif -! call enerprint(energia(0)) - write (iout,'(a,i6,a,1pe16.6)') 'Conformation:',ngen,& - ' energy:',etot -!-------------------------------------------------------------------------- -!... Do Metropolis test -!-------------------------------------------------------------------------- - accepted=.false. - my_conf=.false. - - if (WhatsUp.eq.0 .and. Kwita.eq.0) then - call metropolis(nvar,varia,varold,etot,eold,accepted,& - my_conf,EneLower) - endif - write (iout,*) 'My_Conf=',My_Conf,' EneLower=',EneLower - if (accepted) then - - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -! Check against conformation repetitions. - irepet=conf_comp(varia,etot) - if (print_stat) then -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - endif - call statprint(nacc,nfun,iretcode,etot,elowest) - if (refstr) then - call var_to_geom(nvar,varia) - call chainbuild - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),& !el cref(1,nstart_sup) - nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order',co - endif ! refstr - if (My_Conf) then - nout=nout+1 - write (iout,*) 'Writing new conformation',nout - if (refstr) then - write (istat,'(i5,16(1pe14.5))') nout,& - (energia(print_order(i)),i=1,nprint_ene),& - etot,rms,frac - else - if (print_stat) & - write (istat,'(i5,17(1pe14.5))') nout,& - (energia(print_order(i)),i=1,nprint_ene),etot - endif ! refstr - if (print_stat) close(istat) -! Print internal coordinates. - if (print_int) call briefout(nout,etot) -! Accumulate the newly accepted conf in the coord1 array, if it is different -! from all confs that are already there. - call compare_s1(n_thr,max_thread2,etot,varia,ii,& - enetb1,coord1,rms_deform,.true.,iprint) - write (iout,*) 'After compare_ss: n_thr=',n_thr - if (ii.eq.1 .or. ii.eq.3) then - write (iout,'(8f10.4)') & - (rad2deg*coord1(i,n_thr),i=1,nvar) - endif - else - write (iout,*) 'Conformation from cache, not written.' - endif ! My_Conf - - if (nrepm.gt.maxrepm) then - write (iout,'(a)') 'Too many conformation repetitions.' - goto 20 - endif -! Store the accepted conf. and its energy. - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - if (irepet.eq.0) call zapis(varia,etot) -! Lower the temperature, if necessary. - call cool - - else - - ntrial=ntrial+1 - endif ! accepted - endif ! overlap - - 30 continue - enddo ! accepted -! Check for time limit. - if (ovrtim()) WhatsUp=-1 - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) & - .and. (Kwita.eq.0) - - enddo ! not_done - goto 21 - 20 WhatsUp=-3 - - 21 continue - runtime=tcpu() - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') & - 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - if (it.ge.maxacc) & - write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - !(maxvar) (maxvar=6*maxres) - return - end subroutine do_mcm -#endif -!----------------------------------------------------------------------------- -#ifdef MPI - subroutine do_mcm(i_orig) - -! Monte-Carlo-with-Minimization calculations - parallel code. - use MPI_data - use control_data, only:refstr!,tag - use io_base, only:intout,briefout - use control, only:ovrtim,tcpu - use compare, only:contact,contact_fract - use minimm, only:minimize - use regularize_, only:fitsq -! use contact_, only:contact -! use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.MCM' -! include 'COMMON.CONTACTS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.INFO' -! include 'COMMON.CACHE' -!rc include 'COMMON.DEFORM' -!rc include 'COMMON.DEFORM1' -!rc include 'COMMON.DEFORM2' -! include 'COMMON.MINIM' -! include 'COMMON.NAMES' - logical :: accepted,over,error,lprint,not_done,similar,& - enelower,non_conv,flag,finish !,ovrtim - integer :: MoveType,nbond !,conf_comp - real(kind=8),dimension(6*nres) :: x1,varold1,varold,varia !(maxvar) (maxvar=6*maxres) - real(kind=8) :: elowest,eold - real(kind=8) :: przes(3),obr(3,3) - integer :: iparentx(max_threadss2) - integer :: iparentx1(max_threadss2) - integer :: imtasks(150),imtasks_n - real(kind=8) :: energia(0:n_ene) - -!el local variables - integer :: nfun,nodenum,i_orig,i,nf,nacc,it,nout,j,kkk,is,& - Kwita,iretcode,noverlap,nstart_grow,ierr,iitt,& - ii_grnum_d,ii_ennum_d,ii_hesnum_d,i_grnum_d,i_ennum_d,& - i_hesnum_d,i_minimiz,irepet - real(kind=8) :: etot,frac,eneglobal,RandOrPert,eold1,co,& - runtime,rms - -! if(.not.allocated(varsave)) allocate(varsave(maxvar,maxsave)) !(maxvar,maxsave) - print *,'Master entered DO_MCM' - nodenum = nprocs - - finish=.false. - imtasks_n=0 - do i=1,nodenum-1 - imtasks(i)=0 - enddo -!--------------------------------------------------------------------------- -! Initialize counters. -!--------------------------------------------------------------------------- -! Total number of generated confs. - ngen=0 -! Total number of moves. In general this won`t be equal to the number of -! attempted moves, because we may want to reject some "bad" confs just by -! overlap check. - nmove=0 -! Total number of temperature jumps. - ntherm=0 -! Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -! motions. - allocate(nbond_move(nres)) !(maxres) - - ncache=0 - do i=1,nres - nbond_move(i)=0 - enddo -! Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -! Total number of energy evaluations. - neneval=0 - nfun=0 - nsave=0 -! write (iout,*) 'RanFract=',RanFract - WhatsUp=0 - Kwita=0 -!---------------------------------------------------------------------------- -! Compute and print initial energies. -!---------------------------------------------------------------------------- - call intout - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - nf=0 - call etotal(energia) - etot = energia(0) - call enerprint(energia) -! Request energy computation from slave processors. - call geom_to_var(nvar,varia) -! write (iout,*) 'The VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - call chainbuild - write (iout,*) 'etot from MINIMIZE:',etot -! write (iout,*) 'Tha VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - neneval=0 - eneglobal=1.0d99 - if (print_mc .gt. 0) write (iout,'(/80(1h*)/20x,a/80(1h*))') & - 'Enter Monte Carlo procedure.' - if (print_mc .gt. 0) write (iout,'(i5,1pe14.5)' ) i_orig,etot - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - elowest=etot - call zapis(varia,etot) -! diagnostics - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energia) - if (print_mc.gt.0) write (iout,*) 'Initial energy:',etot -! end diagnostics - nacc=0 ! total # of accepted confs of the current processor. - nacc_tot=0 ! total # of accepted confs of all processors. - not_done=.true. -!---------------------------------------------------------------------------- -! Main loop. -!---------------------------------------------------------------------------- - it=0 - nout=0 - LOOP1:do while (not_done) - it=it+1 - if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') & - 'Beginning iteration #',it -! Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - LOOP2:do while (.not. accepted) - - LOOP3:do while (imtasks_n.lt.nodenum-1.and..not.finish) - do i=1,nodenum-1 - if(imtasks(i).eq.0) then - is=i - exit - endif - enddo -! Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -! Rebuild the chain. - call chainbuild -! Heat up the system, if necessary. - call heat(over) -! If temperature cannot be further increased, stop. - if (over) then - finish=.true. - endif - MoveType=0 - nbond=0 -! write (iout,'(a)') 'Old variables:' -! write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) -! Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) & - write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) -! print *,'after perturb',error,finish - if (error) finish = .true. - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',& - MoveType,' returned from PERTURB.' - finish=.true. - write (*,'(/a,i7,a/)') 'Error - unknown MoveType=',& - MoveType,' returned from PERTURB.' - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) & - write (iout,'(2a,i3)') 'Random-generated conformation',& - ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) - ngen=ngen+1 -! print *,'finish=',finish - if (etot-elowest.gt.overlap_cut) then - if (print_mc.gt.1) write (iout,'(a,1pe14.5)') & - 'Overlap detected in the current conf.; energy is',etot - if(iprint.gt.1.or.etot.lt.1d19) print *,& - 'Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,*) 'Too many overlapping confs.',& - ' etot, elowest, overlap_cut', etot, elowest, overlap_cut - finish=.true. - endif - else if (.not. finish) then -! Distribute tasks to processors -! print *,'Master sending order' - call MPI_SEND(12, 1, MPI_INTEGER, is, tag,& - CG_COMM, ierr) -! write (iout,*) '12: tag=',tag -! print *,'Master sent order to processor',is - call MPI_SEND(it, 1, MPI_INTEGER, is, tag,& - CG_COMM, ierr) -! write (iout,*) 'it: tag=',tag - call MPI_SEND(eold, 1, MPI_DOUBLE_PRECISION, is, tag,& - CG_COMM, ierr) -! write (iout,*) 'eold: tag=',tag - call MPI_SEND(varia(1), nvar, MPI_DOUBLE_PRECISION, & - is, tag,& - CG_COMM, ierr) -! write (iout,*) 'varia: tag=',tag - call MPI_SEND(varold(1), nvar, MPI_DOUBLE_PRECISION, & - is, tag,& - CG_COMM, ierr) -! write (iout,*) 'varold: tag=',tag -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - imtasks(is)=1 - imtasks_n=imtasks_n+1 -! End distribution - endif ! overlap - enddo LOOP3 - - flag = .false. - LOOP_RECV:do while(.not.flag) - do is=1, nodenum-1 - call MPI_IPROBE(is,tag,CG_COMM,flag,status,ierr) - if(flag) then - call MPI_RECV(iitt, 1, MPI_INTEGER, is, tag,& - CG_COMM, status, ierr) - call MPI_RECV(eold1, 1, MPI_DOUBLE_PRECISION, is, tag,& - CG_COMM, status, ierr) - call MPI_RECV(etot, 1, MPI_DOUBLE_PRECISION, is, tag,& - CG_COMM, status, ierr) - call MPI_RECV(varia(1), nvar, MPI_DOUBLE_PRECISION,is,tag,& - CG_COMM, status, ierr) - call MPI_RECV(varold1(1), nvar, MPI_DOUBLE_PRECISION, is, & - tag, CG_COMM, status, ierr) - call MPI_RECV(ii_grnum_d, 1, MPI_INTEGER, is, tag,& - CG_COMM, status, ierr) - call MPI_RECV(ii_ennum_d, 1, MPI_INTEGER, is, tag,& - CG_COMM, status, ierr) - call MPI_RECV(ii_hesnum_d, 1, MPI_INTEGER, is, tag,& - CG_COMM, status, ierr) - i_grnum_d=i_grnum_d+ii_grnum_d - i_ennum_d=i_ennum_d+ii_ennum_d - neneval = neneval+ii_ennum_d - i_hesnum_d=i_hesnum_d+ii_hesnum_d - i_minimiz=i_minimiz+1 - imtasks(is)=0 - imtasks_n=imtasks_n-1 - exit - endif - enddo - enddo LOOP_RECV - - if(print_mc.gt.0) write (iout,'(a,i6,a,i6,a,i6,a,1pe16.6)') & - 'From Worker #',is,' iitt',iitt,& - ' Conformation:',ngen,' energy:',etot -!-------------------------------------------------------------------------- -!... Do Metropolis test -!-------------------------------------------------------------------------- - call metropolis(nvar,varia,varold1,etot,eold1,accepted,& - similar,EneLower) - if(iitt.ne.it.and..not.similar) then - call metropolis(nvar,varia,varold,etot,eold,accepted,& - similar,EneLower) - accepted=enelower - endif - if(etot.lt.eneglobal)eneglobal=etot -! if(mod(it,100).eq.0) - write(iout,*)'CHUJOJEB ',neneval,eneglobal - if (accepted) then -! Write the accepted conformation. - nout=nout+1 - if (refstr) then - call var_to_geom(nvar,varia) - call chainbuild - kkk=1 - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk),& - nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') & - 'RMS deviation from the reference structure:',rms,& - ' % of native contacts:',frac*100,' contact order:',co - endif ! refstr - if (print_mc.gt.0) & - write (iout,*) 'Writing new conformation',nout - if (print_stat) then - call var_to_geom(nvar,varia) -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - if (refstr) then - write (istat,'(i5,16(1pe14.5))') nout,& - (energia(print_order(i)),i=1,nprint_ene),& - etot,rms,frac - else - write (istat,'(i5,16(1pe14.5))') nout,& - (energia(print_order(i)),i=1,nprint_ene),etot - endif ! refstr - close(istat) - endif ! print_stat -! Print internal coordinates. - if (print_int) call briefout(nout,etot) - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -! Check against conformation repetitions. - irepet=conf_comp(varia,etot) - if (nrepm.gt.maxrepm) then - if (print_mc.gt.0) & - write (iout,'(a)') 'Too many conformation repetitions.' - finish=.true. - endif -! Store the accepted conf. and its energy. - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - if (irepet.eq.0) call zapis(varia,etot) -! Lower the temperature, if necessary. - call cool - else - ntrial=ntrial+1 - endif ! accepted - 30 continue - if(finish.and.imtasks_n.eq.0)exit LOOP2 - enddo LOOP2 ! accepted -! Check for time limit. - not_done = (it.lt.max_mcm_it) .and. (nacc_tot.lt.maxacc) - if(.not.not_done .or. finish) then - if(imtasks_n.gt.0) then - not_done=.true. - else - not_done=.false. - endif - finish=.true. - endif - enddo LOOP1 ! not_done - runtime=tcpu() - if (print_mc.gt.0) then - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') & - 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - if (it.ge.maxacc) & - write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - endif -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - do is=1,nodenum-1 - call MPI_SEND(999, 1, MPI_INTEGER, is, tag,& - CG_COMM, ierr) - enddo - return - end subroutine do_mcm -!----------------------------------------------------------------------------- - subroutine execute_slave(nodeinfo,iprint) - - use MPI_data - use minimm, only:minimize -! use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.TIME1' -! include 'COMMON.IOUNITS' -!rc include 'COMMON.DEFORM' -!rc include 'COMMON.DEFORM1' -!rc include 'COMMON.DEFORM2' -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.INFO' -! include 'COMMON.MINIM' - character(len=10) :: nodeinfo - real(kind=8),dimension(6*nres) :: x,x1 !(maxvar) (maxvar=6*maxres) - integer :: nfun,iprint,i_switch,ierr,i_grnum_d,i_ennum_d,& - i_hesnum_d,iitt,iretcode,iminrep - real(kind=8) :: ener,energyx - - nodeinfo='chujwdupe' -! print *,'Processor:',MyID,' Entering execute_slave' - tag=0 -! call MPI_SEND(nodeinfo, 10, MPI_CHARACTER, 0, tag, -! & CG_COMM, ierr) - -1001 call MPI_RECV(i_switch, 1, MPI_INTEGER, 0, tag,& - CG_COMM, status, ierr) -! write(iout,*)'12: tag=',tag - if(iprint.ge.2)print *, MyID,' recv order ',i_switch - if (i_switch.eq.12) then - i_grnum_d=0 - i_ennum_d=0 - i_hesnum_d=0 - call MPI_RECV(iitt, 1, MPI_INTEGER, 0, tag,& - CG_COMM, status, ierr) -! write(iout,*)'12: tag=',tag - call MPI_RECV(ener, 1, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, status, ierr) -! write(iout,*)'ener: tag=',tag - call MPI_RECV(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, status, ierr) -! write(iout,*)'x: tag=',tag - call MPI_RECV(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, status, ierr) -! write(iout,*)'x1: tag=',tag -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif -! print *,'calling minimize' - call minimize(energyx,x,iretcode,nfun) - if(iprint.gt.0) & - write(iout,100)'minimized energy = ',energyx,& - ' # funeval:',nfun,' iret ',iretcode - write(*,100)'minimized energy = ',energyx,& - ' # funeval:',nfun,' iret ',iretcode - 100 format(a20,f10.5,a12,i5,a6,i2) - if(iretcode.eq.10) then - do iminrep=2,3 - if(iprint.gt.1) & - write(iout,*)' ... not converged - trying again ',iminrep - call minimize(energyx,x,iretcode,nfun) - if(iprint.gt.1) & - write(iout,*)'minimized energy = ',energyx,& - ' # funeval:',nfun,' iret ',iretcode - if(iretcode.ne.10)go to 812 - enddo - if(iretcode.eq.10) then - if(iprint.gt.1) & - write(iout,*)' ... not converged again - giving up' - go to 812 - endif - endif -812 continue -! print *,'Sending results' - call MPI_SEND(iitt, 1, MPI_INTEGER, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(ener, 1, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(energyx, 1, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(i_grnum_d, 1, MPI_INTEGER, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(nfun, 1, MPI_INTEGER, 0, tag,& - CG_COMM, ierr) - call MPI_SEND(i_hesnum_d, 1, MPI_INTEGER, 0, tag,& - CG_COMM, ierr) -! print *,'End sending' - go to 1001 - endif - - return - end subroutine execute_slave -#endif -!----------------------------------------------------------------------------- - subroutine heat(over) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' - logical :: over -! Check if there`s a need to increase temperature. - if (ntrial.gt.maxtrial) then - if (NstepH.gt.0) then - if (dabs(Tcur-TMax).lt.1.0D-7) then - if (print_mc.gt.0) & - write (iout,'(/80(1h*)/a,f8.3,a/80(1h*))') & - 'Upper limit of temperature reached. Terminating.' - over=.true. - Tcur=Tmin - else - Tcur=Tcur*TstepH - if (Tcur.gt.Tmax) Tcur=Tmax - betbol=1.0D0/(Rbol*Tcur) - if (print_mc.gt.0) & - write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') & - 'System heated up to ',Tcur,' K; BetBol:',betbol - ntherm=ntherm+1 - ntrial=0 - over=.false. - endif - else - if (print_mc.gt.0) & - write (iout,'(a)') & - 'Maximum number of trials in a single MCM iteration exceeded.' - over=.true. - Tcur=Tmin - endif - else - over=.false. - endif - return - end subroutine heat -!----------------------------------------------------------------------------- - subroutine cool - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' - if (nstepC.gt.0 .and. dabs(Tcur-Tmin).gt.1.0D-7) then - Tcur=Tcur/TstepC - if (Tcur.lt.Tmin) Tcur=Tmin - betbol=1.0D0/(Rbol*Tcur) - if (print_mc.gt.0) & - write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') & - 'System cooled down up to ',Tcur,' K; BetBol:',betbol - endif - return - end subroutine cool -!----------------------------------------------------------------------------- - subroutine perturb(error,lprint,MoveType,nbond,max_phi) - - use geometry - use energy, only:nnt,nct,itype - use md_calc, only:bond_move -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer,parameter :: MMaxSideMove=100 -! include 'COMMON.MCM' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -!rc include 'COMMON.DEFORM1' - logical :: error,lprint,fail - integer :: MoveType,nbond,end_select,ind_side(MMaxSideMove) - real(kind=8) :: max_phi - real(kind=8) :: psi!,gen_psi -!el external iran_num -!el integer iran_num - integer :: ifour - -!!! local variables - el - integer :: itrial,iiwin,iwindow,isctry,i,icount,j,nstart,& - nside_move,inds,indx,ii,iti - real(kind=8) :: bond_prob,theta_new - - data ifour /4/ - error=.false. - lprint=.false. -! Perturb the conformation according to a randomly selected move. - call SelectMove(MoveType) -! write (iout,*) 'MoveType=',MoveType - itrial=0 - goto (100,200,300,400,500) MoveType -!------------------------------------------------------------------------------ -! Backbone N-bond move. -! Select the number of bonds (length of the segment to perturb). - 100 continue - if (itrial.gt.1000) then - write (iout,'(a)') 'Too many attempts at multiple-bond move.' - error=.true. - return - endif - bond_prob=ran_number(0.0D0,sumpro_bond(nbm)) -! print *,'sumpro_bond(nbm)=',sumpro_bond(nbm), -! & ' Bond_prob=',Bond_Prob - do i=1,nbm-1 -! print *,i,Bond_Prob,sumpro_bond(i),sumpro_bond(i+1) - if (bond_prob.ge.sumpro_bond(i) .and. & - bond_prob.le.sumpro_bond(i+1)) then - nbond=i+1 - goto 10 - endif - enddo - write (iout,'(2a)') 'In PERTURB: Error - number of bonds',& - ' to move out of range.' - error=.true. - return - 10 continue - if (nwindow.gt.0) then -! Select the first residue to perturb - iwindow=iran_num(1,nwindow) - print *,'iwindow=',iwindow - iiwin=1 - do while (winlen(iwindow).lt.nbond) - iwindow=iran_num(1,nwindow) - iiwin=iiwin+1 - if (iiwin.gt.1000) then - write (iout,'(a)') 'Cannot select moveable residues.' - error=.true. - return - endif - enddo - nstart=iran_num(winstart(iwindow),winend(iwindow)) - else - nstart = iran_num(koniecl+2,nres-nbond-koniecl) -!d print *,'nres=',nres,' nbond=',nbond,' koniecl=',koniecl, -!d & ' nstart=',nstart - endif - psi = gen_psi() - if (psi.eq.0.0) then - error=.true. - return - endif - if (print_mc.gt.1) write (iout,'(a,i4,a,i4,a,f8.3)') & - 'PERTURB: nbond=',nbond,' nstart=',nstart,' psi=',psi*rad2deg -!d print *,'nstart=',nstart - call bond_move(nbond,nstart,psi,.false.,error) - if (error) then - write (iout,'(2a)') & - 'Could not define reference system in bond_move, ',& - 'choosing ahother segment.' - itrial=itrial+1 - goto 100 - endif - nbond_move(nbond)=nbond_move(nbond)+1 - moves(1)=moves(1)+1 - nmove=nmove+1 - return -!------------------------------------------------------------------------------ -! Backbone endmove. Perturb a SINGLE angle of a residue close to the end of -! the chain. - 200 continue - lprint=.true. -! end_select=iran_num(1,2*koniecl) -! if (end_select.gt.koniecl) then -! end_select=nphi-(end_select-koniecl) -! else -! end_select=koniecl+3 -! endif -! if (nwindow.gt.0) then -! iwin=iran_num(1,nwindow) -! i1=max0(4,winstart(iwin)) -! i2=min0(winend(imin)+2,nres) -! end_select=iran_num(i1,i2) -! else -! iselect = iran_num(1,nmov_var) -! jj = 0 -! do i=1,nphi -! if (isearch_tab(i).eq.1) jj = jj+1 -! if (jj.eq.iselect) then -! end_select=i+3 -! exit -! endif -! enddo -! endif - end_select = iran_num(4,nres) - psi=max_phi*gen_psi() - if (psi.eq.0.0D0) then - error=.true. - return - endif - phi(end_select)=pinorm(phi(end_select)+psi) - if (print_mc.gt.1) write (iout,'(a,i4,a,f8.3,a,f8.3)') & - 'End angle',end_select,' moved by ',psi*rad2deg,' new angle:',& - phi(end_select)*rad2deg -! if (end_select.gt.3) -! & theta(end_select-1)=gen_theta(itype(end_select-2), -! & phi(end_select-1),phi(end_select)) -! if (end_select.lt.nres) -! & theta(end_select)=gen_theta(itype(end_select-1), -! & phi(end_select),phi(end_select+1)) -!d print *,'nres=',nres,' end_select=',end_select -!d print *,'theta',end_select-1,theta(end_select-1) -!d print *,'theta',end_select,theta(end_select) - moves(2)=moves(2)+1 - nmove=nmove+1 - lprint=.false. - return -!------------------------------------------------------------------------------ -! Side chain move. -! Select the number of SCs to perturb. - 300 isctry=0 - 301 nside_move=iran_num(1,MaxSideMove) -! print *,'nside_move=',nside_move,' MaxSideMove',MaxSideMove -! Select the indices. - do i=1,nside_move - icount=0 - 111 inds=iran_num(nnt,nct) - icount=icount+1 - if (icount.gt.1000) then - write (iout,'(a)')'Error - cannot select side chains to move.' - error=.true. - return - endif - if (itype(inds).eq.10) goto 111 - do j=1,i-1 - if (inds.eq.ind_side(j)) goto 111 - enddo - do j=1,i-1 - if (inds.lt.ind_side(j)) then - indx=j - goto 112 - endif - enddo - indx=i - 112 do j=i,indx+1,-1 - ind_side(j)=ind_side(j-1) - enddo - 113 ind_side(indx)=inds - enddo -! Carry out perturbation. - do i=1,nside_move - ii=ind_side(i) - iti=itype(ii) - call gen_side(iti,theta(ii+1),alph(ii),omeg(ii),fail) - if (fail) then - isctry=isctry+1 - if (isctry.gt.1000) then - write (iout,'(a)') 'Too many errors in SC generation.' - error=.true. - return - endif - goto 301 - endif - if (print_mc.gt.1) write (iout,'(2a,i4,a,2f8.3)') & - 'Side chain ',restyp(iti),ii,' moved to ',& - alph(ii)*rad2deg,omeg(ii)*rad2deg - enddo - moves(3)=moves(3)+1 - nmove=nmove+1 - return -!------------------------------------------------------------------------------ -! THETA move - 400 end_select=iran_num(3,nres) - theta_new=gen_theta(itype(end_select),phi(end_select),& - phi(end_select+1)) - if (print_mc.gt.1) write (iout,'(a,i3,a,f8.3,a,f8.3)') & - 'Theta ',end_select,' moved from',theta(end_select)*rad2deg,& - ' to ',theta_new*rad2deg - theta(end_select)=theta_new - moves(4)=moves(4)+1 - nmove=nmove+1 - return -!------------------------------------------------------------------------------ -! Error returned from SelectMove. - 500 error=.true. - return - end subroutine perturb -!----------------------------------------------------------------------------- - subroutine SelectMove(MoveType) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' - -!!! local variables - el - integer :: i,MoveType - real(kind=8) :: what_move - - what_move=ran_number(0.0D0,sumpro_type(MaxMoveType)) - do i=1,MaxMoveType - if (what_move.ge.sumpro_type(i-1).and. & - what_move.lt.sumpro_type(i)) then - MoveType=i - return - endif - enddo - write (iout,'(a)') & - 'Fatal error in SelectMoveType: cannot select move.' - MoveType=MaxMoveType+1 - return - end subroutine SelectMove -!----------------------------------------------------------------------------- - real(kind=8) function gen_psi() - - use geometry_data, only: angmin,pi -!el implicit none - integer :: i - real(kind=8) :: x !,ran_number -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' - x=0.0D0 - do i=1,100 - x=ran_number(-pi,pi) - if (dabs(x).gt.angmin) then - gen_psi=x - return - endif - enddo - write (iout,'(a)')'From Gen_Psi: Cannot generate angle increment.' - gen_psi=0.0D0 - return - end function gen_psi -!----------------------------------------------------------------------------- - subroutine metropolis(n,xcur,xold,ecur,eold,accepted,similar,enelower) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -!rc include 'COMMON.DEFORM' - integer :: n - real(kind=8) :: ecur,eold,xx,bol !,ran_number - real(kind=8),dimension(n) :: xcur,xold - real(kind=8) :: ecut1 ,ecut2 ,tola - logical :: accepted,similar,not_done,enelower - logical :: lprn - -!!! local variables - el - real(kind=8) :: xxh,difene,reldife - - data ecut1 /-1.0D-5/,ecut2 /5.0D-3/,tola/5.0D0/ -! ecut1=-5*enedif -! ecut2=50*enedif -! tola=5.0d0 -! Set lprn=.true. for debugging. - lprn=.false. - if (lprn) & -!el write(iout,*)'enedif',enedif,' ecut1',ecut1,' ecut2',ecut2 - write(iout,*)' ecut1',ecut1,' ecut2',ecut2 - similar=.false. - enelower=.false. - accepted=.false. -! Check if the conformation is similar. - difene=ecur-eold - reldife=difene/dmax1(dabs(eold),dabs(ecur),1.0D0) - if (lprn) then - write (iout,*) 'Metropolis' - write(iout,*)'ecur,eold,difene,reldife',ecur,eold,difene,reldife - endif -! If energy went down remarkably, we accept the new conformation -! unconditionally. -!jp if (reldife.lt.ecut1) then - if (difene.lt.ecut1) then - accepted=.true. - EneLower=.true. - if (lprn) write (iout,'(a)') & - 'Conformation accepted, because energy has lowered remarkably.' -! elseif (reldife.lt.ecut2 .and. dif_ang(nphi,xcur,xold).lt.tola) -!jp elseif (reldife.lt.ecut2) - elseif (difene.lt.ecut2) & - then -! Reject the conf. if energy has changed insignificantly and there is not -! much change in conformation. - if (lprn) & - write (iout,'(2a)') 'Conformation rejected, because it is',& - ' similar to the preceding one.' - accepted=.false. - similar=.true. - else -! Else carry out Metropolis test. - EneLower=.false. - xx=ran_number(0.0D0,1.0D0) - xxh=betbol*difene - if (lprn) & - write (iout,*) 'betbol=',betbol,' difene=',difene,' xxh=',xxh - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (lprn) write (iout,*) 'bol=',bol,' xx=',xx - if (bol.gt.xx) then - accepted=.true. - if (lprn) write (iout,'(a)') & - 'Conformation accepted, because it passed Metropolis test.' - else - accepted=.false. - if (lprn) write (iout,'(a)') & - 'Conformation rejected, because it did not pass Metropolis test.' - endif - endif -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - return - end subroutine metropolis -!----------------------------------------------------------------------------- - integer function conf_comp(x,ene) - - use geometry_data, only: nphi -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' - real(kind=8) :: etol, angtol - real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) - real(kind=8) :: difa !dif_ang, - -!!! local variables - el - integer :: ii,i - real(kind=8) :: ene - - data etol /0.1D0/, angtol /20.0D0/ - do ii=nsave,1,-1 -! write (iout,*) 'ii=',ii,'ene=',ene,esave(ii),dabs(ene-esave(ii)) - if (dabs(ene-esave(ii)).lt.etol) then - difa=dif_ang(nphi,x,varsave(1,ii)) -! do i=1,nphi -! write(iout,'(i3,3f8.3)')i,rad2deg*x(i), -! & rad2deg*varsave(i,ii) -! enddo -! write(iout,*) 'ii=',ii,' difa=',difa,' angtol=',angtol - if (difa.le.angtol) then - if (print_mc.gt.0) then - write (iout,'(a,i5,2(a,1pe15.4))') & - 'Current conformation matches #',ii,& - ' in the store array ene=',ene,' esave=',esave(ii) -! write (*,'(a,i5,a)') 'Current conformation matches #',ii, -! & ' in the store array.' - endif ! print_mc.gt.0 - if (print_mc.gt.1) then - do i=1,nphi - write(iout,'(i3,3f8.3)')i,rad2deg*x(i),& - rad2deg*varsave(i,ii) - enddo - endif ! print_mc.gt.1 - nrepm=nrepm+1 - conf_comp=ii - return - endif - endif - enddo - conf_comp=0 - return - end function conf_comp -!----------------------------------------------------------------------------- - real(kind=8) function dif_ang(n,x,y) - - use geometry_data, only: dwapi -!el implicit none - integer :: i,n - real(kind=8),dimension(n) :: x,y - real(kind=8) :: w,wa,dif,difa -!el real(kind=8) :: pinorm -! include 'COMMON.GEO' - wa=0.0D0 - difa=0.0D0 - do i=1,n - dif=dabs(pinorm(y(i)-x(i))) - if (dabs(dif-dwapi).lt.dif) dif=dabs(dif-dwapi) - w=1.0D0-(2.0D0*(i-1)/(n-1)-1.0D0)**2+1.0D0/n - wa=wa+w - difa=difa+dif*dif*w - enddo - dif_ang=rad2deg*dsqrt(difa/wa) - return - end function dif_ang -!----------------------------------------------------------------------------- - subroutine add2cache(n1,n2,ncache,nvar,SourceID,CachSrc,ecur,xcur,ecache,xcache) - -! implicit none -! include 'COMMON.GEO' -! include 'COMMON.IOUNITS' - integer :: n1,n2,ncache,nvar,SourceID,CachSrc(n2) - integer :: i,ii,j - real(kind=8) :: ecur,xcur(nvar),ecache(n2),xcache(n1,n2) -!d write (iout,*) 'Enter ADD2CACHE ncache=',ncache ,' ecur',ecur -!d write (iout,'(10f8.3)') (rad2deg*xcur(i),i=1,nvar) -!d write (iout,*) 'Old CACHE array:' -!d do i=1,ncache -!d write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -!d write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -!d enddo - - i=ncache - do while (i.gt.0 .and. ecur.lt.ecache(i)) - i=i-1 - enddo - i=i+1 -!d write (iout,*) 'i=',i,' ncache=',ncache - if (ncache.eq.n2) then - write (iout,*) 'Cache dimension exceeded',ncache,n2 - write (iout,*) 'Highest-energy conformation will be removed.' - ncache=ncache-1 - endif - do ii=ncache,i,-1 - ecache(ii+1)=ecache(ii) - CachSrc(ii+1)=CachSrc(ii) - do j=1,nvar - xcache(j,ii+1)=xcache(j,ii) - enddo - enddo - ecache(i)=ecur - CachSrc(i)=SourceID - do j=1,nvar - xcache(j,i)=xcur(j) - enddo - ncache=ncache+1 -!d write (iout,*) 'New CACHE array:' -!d do i=1,ncache -!d write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -!d write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -!d enddo - return - end subroutine add2cache -!----------------------------------------------------------------------------- - subroutine rm_from_cache(i,n1,n2,ncache,nvar,CachSrc,ecache,xcache) - -! implicit none -! include 'COMMON.GEO' -! include 'COMMON.IOUNITS' - integer :: n1,n2,ncache,nvar,CachSrc(n2) - integer :: i,ii,j - real(kind=8) :: ecache(n2),xcache(n1,n2) - -!d write (iout,*) 'Enter RM_FROM_CACHE' -!d write (iout,*) 'Old CACHE array:' -!d do ii=1,ncache -!d write (iout,*)'i=',ii,' ecache=',ecache(ii),' CachSrc',CachSrc(ii) -!d write (iout,'(10f8.3)') (rad2deg*xcache(j,ii),j=1,nvar) -!d enddo - - do ii=i+1,ncache - ecache(ii-1)=ecache(ii) - CachSrc(ii-1)=CachSrc(ii) - do j=1,nvar - xcache(j,ii-1)=xcache(j,ii) - enddo - enddo - ncache=ncache-1 -!d write (iout,*) 'New CACHE array:' -!d do i=1,ncache -!d write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -!d write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -!d enddo - return - end subroutine rm_from_cache -!----------------------------------------------------------------------------- -! mcm.F io_mcm -!----------------------------------------------------------------------------- - subroutine statprint(it,nfun,iretcode,etot,elowest) - - use control_data, only: MaxMoveType,minim - use control, only: tcpu - use mcm_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -! include 'COMMON.MCM' -!el local variables - integer :: it,nfun,iretcode,i - real(kind=8) :: etot,elowest,fr_mov_i - - if (minim) then - write (iout,& - '(80(1h*)/a,i5,a,1pe14.5,a,1pe14.5/a,i3,a,i10,a,i5,a,i5)') & - 'Finished iteration #',it,' energy is',etot,& - ' lowest energy:',elowest,& - 'SUMSL return code:',iretcode,& - ' # of energy evaluations:',neneval,& - '# of temperature jumps:',ntherm,& - ' # of minima repetitions:',nrepm - else - write (iout,'(80(1h*)/a,i8,a,1pe14.5,a,1pe14.5)') & - 'Finished iteration #',it,' energy is',etot,& - ' lowest energy:',elowest - endif - write (iout,'(/4a)') & - 'Kind of move ',' total',' accepted',& - ' fraction' - write (iout,'(58(1h-))') - do i=-1,MaxMoveType - if (moves(i).eq.0) then - fr_mov_i=0.0d0 - else - fr_mov_i=dfloat(moves_acc(i))/dfloat(moves(i)) - endif - write(iout,'(a,2i15,f10.5)')MovTypID(i),moves(i),moves_acc(i),& - fr_mov_i - enddo - write (iout,'(a,2i15,f10.5)') 'total ',nmove,nacc_tot,& - dfloat(nacc_tot)/dfloat(nmove) - write (iout,'(58(1h-))') - write (iout,'(a,1pe12.4)') 'Elapsed time:',tcpu() - return - end subroutine statprint -!----------------------------------------------------------------------------- - subroutine zapis(varia,etot) - - use geometry_data, only: nres,rad2deg,nvar - use mcm_data - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - use MPI_data !include 'COMMON.INFO' - include 'mpif.h' -#endif -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' - integer,dimension(nsave) :: itemp - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - logical :: lprint -!el local variables - integer :: j,i,maxvar - real(kind=8) :: etot - -!el allocate(esave(nsave)) !(maxsave) - - maxvar=6*nres - lprint=.false. - if (lprint) then - write (iout,'(a,i5,a,i5)') 'Enter ZAPIS NSave=',Nsave,& - ' MaxSave=',MaxSave - write (iout,'(a)') 'Current energy and conformation:' - write (iout,'(1pe14.5)') etot - write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) - endif -! Shift the contents of the esave and varsave arrays if filled up. - call add2cache(6*nres,nsave,nsave,nvar,MyID,itemp,& - etot,varia,esave,varsave) - if (lprint) then - write (iout,'(a)') 'Energies and the VarSave array.' - do i=1,nsave - write (iout,'(i5,1pe14.5)') i,esave(i) - write (iout,'(10f8.3)') (rad2deg*varsave(j,i),j=1,nvar) - enddo - endif - return - end subroutine zapis -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - subroutine alloc_MCM_arrays - - use energy_data, only: max_ene - use MPI_data -! common.mce -! common /mce/ - allocate(entropy(-max_ene-4:max_ene)) !(-max_ene-4:max_ene) - allocate(nhist(-max_ene:max_ene)) !(-max_ene:max_ene) - allocate(nminima(maxsave)) !(maxsave) -! common /pool/ - allocate(xpool(6*nres,max_pool)) !(maxvar,max_pool)(maxvar=6*maxres) - allocate(epool(max_pool)) !(max_pool) -! commom.mcm -! common /mcm/ - if(.not.allocated(nsave_part)) allocate(nsave_part(nctasks)) !(max_cg_procs) -! common /move/ -! in io: mcmread -! real(kind=8),dimension(:),allocatable :: sumpro_type !(0:MaxMoveType) - allocate(sumpro_bond(0:nres)) !(0:maxres) - allocate(nbond_move(nres),nbond_acc(nres)) !(maxres) - allocate(moves(-1:MaxMoveType+1),moves_acc(-1:MaxMoveType+1)) !(-1:MaxMoveType+1) -! common /accept_stats/ -! allocate(nacc_part !(0:MaxProcs) !el nie uzywane??? -! common /windows/ in io: mcmread -! allocate(winstart,winend,winlen !(maxres) -! common /moveID/ -!el allocate(MovTypID(-1:MaxMoveType+1)) !(-1:MaxMoveType+1) -! common.var -! common /oldgeo/ - allocate(varsave(nres*6,maxsave)) !(maxvar,maxsave)(maxvar=6*maxres) - allocate(esave(maxsave)) !(maxsave) - allocate(Origin(maxsave)) !(maxsave) - - return - end subroutine alloc_MCM_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module mcm_md diff --git a/source/unres/MD.F90 b/source/unres/MD.F90 new file mode 100644 index 0000000..c509ee1 --- /dev/null +++ b/source/unres/MD.F90 @@ -0,0 +1,5680 @@ + module MDyn +!----------------------------------------------------------------------------- + use io_units + use names + use math + use md_calc + use geometry_data + use io_base + use geometry + use energy + use MD_data + use REMD + + implicit none +!----------------------------------------------------------------------------- +! common.MD +! common /mdgrad/ in module.energy +! common /back_constr/ in module.energy +! common /qmeas/ in module.energy +! common /mdpar/ +! common /MDcalc/ +! common /lagrange/ + real(kind=8),dimension(:),allocatable :: d_t_work,& + d_t_work_new,d_af_work,d_as_work,kinetic_force !(MAXRES6) + real(kind=8),dimension(:,:),allocatable :: d_t_new,& + d_a_old,d_a_short!,d_a !(3,0:MAXRES2) +! real(kind=8),dimension(:),allocatable :: d_a_work !(6*MAXRES) +! real(kind=8),dimension(:,:),allocatable :: Gmat,Ginv,A,& +! Gsqrp,Gsqrm,Gvec !(maxres2,maxres2) +! real(kind=8),dimension(:),allocatable :: Geigen !(maxres2) +! integer :: dimen,dimen1,dimen3 +! integer :: lang,count_reset_moment,count_reset_vel +! logical :: reset_moment,reset_vel,rattle,RESPA +! common /inertia/ +! common /langevin/ +! real(kind=8) :: rwat,etawat,stdfp,cPoise +! real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1) +! real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp) + real(kind=8),dimension(:),allocatable :: stdforcp,stdforcsc !(MAXRES) +!----------------------------------------------------------------------------- +! 'sizes.i' +! +! +! ################################################### +! ## COPYRIGHT (C) 1992 by Jay William Ponder ## +! ## All Rights Reserved ## +! ################################################### +! +! ############################################################# +! ## ## +! ## sizes.i -- parameter values to set array dimensions ## +! ## ## +! ############################################################# +! +! +! "sizes.i" sets values for critical array dimensions used +! throughout the software; these parameters will fix the size +! of the largest systems that can be handled; values too large +! for the computer's memory and/or swap space to accomodate +! will result in poor performance or outright failure +! +! parameter: maximum allowed number of: +! +! maxatm atoms in the molecular system +! maxval atoms directly bonded to an atom +! maxgrp ! user-defined groups of atoms +! maxtyp force field atom type definitions +! maxclass force field atom class definitions +! maxkey lines in the keyword file +! maxrot bonds for torsional rotation +! maxvar optimization variables (vector storage) +! maxopt optimization variables (matrix storage) +! maxhess off-diagonal Hessian elements +! maxlight sites for method of lights neighbors +! maxvib vibrational frequencies +! maxgeo distance geometry points +! maxcell unit cells in replicated crystal +! maxring 3-, 4-, or 5-membered rings +! maxfix geometric restraints +! maxbio biopolymer atom definitions +! maxres residues in the macromolecule +! maxamino amino acid residue types +! maxnuc nucleic acid residue types +! maxbnd covalent bonds in molecular system +! maxang bond angles in molecular system +! maxtors torsional angles in molecular system +! maxpi atoms in conjugated pisystem +! maxpib covalent bonds involving pisystem +! maxpit torsional angles involving pisystem +! +! +!el integer maxatm,maxval,maxgrp +!el integer maxtyp,maxclass,maxkey +!el integer maxrot,maxopt +!el integer maxhess,maxlight,maxvib +!el integer maxgeo,maxcell,maxring +!el integer maxfix,maxbio +!el integer maxamino,maxnuc,maxbnd +!el integer maxang,maxtors,maxpi +!el integer maxpib,maxpit + integer :: maxatm !=2*nres !maxres2 maxres2=2*maxres + integer,parameter :: maxval=8 + integer,parameter :: maxgrp=1000 + integer,parameter :: maxtyp=3000 + integer,parameter :: maxclass=500 + integer,parameter :: maxkey=10000 + integer,parameter :: maxrot=1000 + integer,parameter :: maxopt=1000 + integer,parameter :: maxhess=1000000 + integer :: maxlight !=8*maxatm + integer,parameter :: maxvib=1000 + integer,parameter :: maxgeo=1000 + integer,parameter :: maxcell=10000 + integer,parameter :: maxring=10000 + integer,parameter :: maxfix=10000 + integer,parameter :: maxbio=10000 + integer,parameter :: maxamino=31 + integer,parameter :: maxnuc=12 + integer :: maxbnd !=2*maxatm + integer :: maxang !=3*maxatm + integer :: maxtors !=4*maxatm + integer,parameter :: maxpi=100 + integer,parameter :: maxpib=2*maxpi + integer,parameter :: maxpit=4*maxpi +!----------------------------------------------------------------------------- +! Maximum number of seed + integer,parameter :: max_seed=1 +!----------------------------------------------------------------------------- + real(kind=8),dimension(:),allocatable :: stochforcvec !(MAXRES6) maxres6=6*maxres +! common /stochcalc/ stochforcvec +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: rattle1,rattle2,rattle_brown + real(kind=8),dimension(:,:),allocatable :: GGinv !(2*nres,2*nres) maxres2=2*maxres + real(kind=8),dimension(:,:,:),allocatable :: gdc !(3,2*nres,2*nres) maxres2=2*maxres + real(kind=8),dimension(:,:),allocatable :: Cmat !(2*nres,2*nres) maxres2=2*maxres +!----------------------------------------------------------------------------- +! common /syfek/ subroutines: friction_force,setup_fricmat +!el real(kind=8),dimension(:),allocatable :: gamvec !(MAXRES6) or (MAXRES2) +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: friction_force,setup_fricmat + real(kind=8),dimension(:,:),allocatable :: ginvfric !(2*nres,2*nres) !maxres2=2*maxres +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutine: setup_fricmat +!el real(kind=8),dimension(:,:),allocatable :: fcopy !(2*nres,2*nres) +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! brown_step.f +!----------------------------------------------------------------------------- + subroutine brown_step(itime) +!------------------------------------------------ +! Perform a single Euler integration step of Brownian dynamics +!------------------------------------------------ +! implicit real*8 (a-h,o-z) + use comm_gucio + use control, only: tcpu + use control_data + use energy_data +! use io_conf, only:cartprint +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8),dimension(6*nres) :: zapas !(MAXRES6) maxres6=6*maxres + integer :: rstcount !ilen, +!el external ilen +!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres + real(kind=8),dimension(6*nres,2*nres) :: Bmat,GBmat,Tmat !(MAXRES6,MAXRES2) (maxres2=2*maxres,maxres6=6*maxres) + real(kind=8),dimension(2*nres,2*nres) :: Cmat_,Cinv !(maxres2,maxres2) maxres2=2*maxres + real(kind=8),dimension(6*nres,6*nres) :: Pmat !(maxres6,maxres6) maxres6=6*maxres + real(kind=8),dimension(6*nres) :: Td !(maxres6) maxres6=6*maxres + real(kind=8),dimension(2*nres) :: ppvec !(maxres2) maxres2=2*maxres +!el common /stochcalc/ stochforcvec +!el real(kind=8),dimension(3) :: cm !el +!el common /gucio/ cm + integer :: itime + logical :: lprn = .false.,lprn1 = .false. + integer :: maxiter = 5 + real(kind=8) :: difftol = 1.0d-5 + real(kind=8) :: xx,diffmax,blen2,diffbond,tt0 + integer :: i,j,nbond,k,ind,ind1,iter + integer :: nres2,nres6 + logical :: osob + nres2=2*nres + nres6=6*nres + + if (.not.allocated(stochforcvec)) allocate(stochforcvec(nres6)) !(MAXRES6) maxres6=6*maxres + + nbond=nct-nnt + do i=nnt,nct + if (itype(i).ne.10) nbond=nbond+1 + enddo +! + if (lprn1) then + write (iout,*) "Generalized inverse of fricmat" + call matout(dimen,dimen,nres6,nres6,fricmat) + endif + do i=1,dimen + do j=1,nbond + Bmat(i,j)=0.0d0 + enddo + enddo + ind=3 + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + do j=1,3 + Bmat(ind+j,ind1)=dC_norm(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind1=ind1+1 + do j=1,3 + Bmat(ind+j,ind1)=dC_norm(j,i+nres) + enddo + ind=ind+3 + endif + enddo + if (lprn1) then + write (iout,*) "Matrix Bmat" + call MATOUT(nbond,dimen,nres6,nres6,Bmat) + endif + do i=1,dimen + do j=1,nbond + GBmat(i,j)=0.0d0 + do k=1,dimen + GBmat(i,j)=GBmat(i,j)+fricmat(i,k)*Bmat(k,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix GBmat" + call MATOUT(nbond,dimen,nres6,nres2,Gbmat) + endif + do i=1,nbond + do j=1,nbond + Cmat_(i,j)=0.0d0 + do k=1,dimen + Cmat_(i,j)=Cmat_(i,j)+Bmat(k,i)*GBmat(k,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,nres2,nres2,Cmat_) + endif + call matinvert(nbond,nres2,Cmat_,Cinv,osob) + if (lprn1) then + write (iout,*) "Matrix Cinv" + call MATOUT(nbond,nbond,nres2,nres2,Cinv) + endif + do i=1,dimen + do j=1,nbond + Tmat(i,j)=0.0d0 + do k=1,nbond + Tmat(i,j)=Tmat(i,j)+GBmat(i,k)*Cinv(k,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Tmat" + call MATOUT(nbond,dimen,nres6,nres2,Tmat) + endif + do i=1,dimen + do j=1,dimen + if (i.eq.j) then + Pmat(i,j)=1.0d0 + else + Pmat(i,j)=0.0d0 + endif + do k=1,nbond + Pmat(i,j)=Pmat(i,j)-Tmat(i,k)*Bmat(j,k) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Pmat" + call MATOUT(dimen,dimen,nres6,nres6,Pmat) + endif + do i=1,dimen + Td(i)=0.0d0 + ind=0 + do k=nnt,nct-1 + ind=ind+1 + Td(i)=Td(i)+vbl*Tmat(i,ind) + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + Td(i)=Td(i)+vbldsc0(1,itype(k))*Tmat(i,ind) + endif + enddo + enddo + if (lprn1) then + write (iout,*) "Vector Td" + do i=1,dimen + write (iout,'(i5,f10.5)') i,Td(i) + enddo + endif + call stochastic_force(stochforcvec) + if (lprn) then + write (iout,*) "stochforcvec" + do i=1,dimen + write (iout,*) i,stochforcvec(i) + enddo + endif + do j=1,3 + zapas(j)=-gcart(j,0)+stochforcvec(j) + d_t_work(j)=d_t(j,0) + dC_work(j)=dC_old(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + zapas(ind)=-gcart(j,i)+stochforcvec(ind) + dC_work(ind)=dC_old(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + ind=ind+1 + zapas(ind)=-gxcart(j,i)+stochforcvec(ind) + dC_work(ind)=dC_old(j,i+nres) + enddo + endif + enddo + + if (lprn) then + write (iout,*) "Initial d_t_work" + do i=1,dimen + write (iout,*) i,d_t_work(i) + enddo + endif + + do i=1,dimen + d_t_work(i)=0.0d0 + do j=1,dimen + d_t_work(i)=d_t_work(i)+fricmat(i,j)*zapas(j) + enddo + enddo + + do i=1,dimen + zapas(i)=Td(i) + do j=1,dimen + zapas(i)=zapas(i)+Pmat(i,j)*(dC_work(j)+d_t_work(j)*d_time) + enddo + enddo + if (lprn1) then + write (iout,*) "Final d_t_work and zapas" + do i=1,dimen + write (iout,*) i,d_t_work(i),zapas(i) + enddo + endif + + do j=1,3 + d_t(j,0)=d_t_work(j) + dc(j,0)=zapas(j) + dc_work(j)=dc(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_work(i) + dc(j,i)=zapas(ind+j) + dc_work(ind+j)=dc(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + do j=1,3 + d_t(j,i+nres)=d_t_work(ind+j) + dc(j,i+nres)=zapas(ind+j) + dc_work(ind+j)=dc(j,i+nres) + enddo + ind=ind+3 + enddo + if (lprn) then + call chainbuild_cart + write (iout,*) "Before correction for rotational lengthening" + write (iout,*) "New coordinates",& + " and differences between actual and standard bond lengths" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + xx=vbld(i+1)-vbl + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i),j=1,3),xx + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + xx=vbld(i+nres)-vbldsc0(1,itype(i)) + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i+nres),j=1,3),xx + endif + enddo + endif +! Second correction (rotational lengthening) +! do iter=1,maxiter + diffmax=0.0d0 + ind=0 + do i=nnt,nct-1 + ind=ind+1 + blen2 = scalar(dc(1,i),dc(1,i)) + ppvec(ind)=2*vbl**2-blen2 + diffbond=dabs(vbl-dsqrt(blen2)) + if (diffbond.gt.diffmax) diffmax=diffbond + if (ppvec(ind).gt.0.0d0) then + ppvec(ind)=dsqrt(ppvec(ind)) + else + ppvec(ind)=0.0d0 + endif + if (lprn) then + write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) + endif + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + blen2 = scalar(dc(1,i+nres),dc(1,i+nres)) + ppvec(ind)=2*vbldsc0(1,itype(i))**2-blen2 + diffbond=dabs(vbldsc0(1,itype(i))-dsqrt(blen2)) + if (diffbond.gt.diffmax) diffmax=diffbond + if (ppvec(ind).gt.0.0d0) then + ppvec(ind)=dsqrt(ppvec(ind)) + else + ppvec(ind)=0.0d0 + endif + if (lprn) then + write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) + endif + endif + enddo + if (lprn) write (iout,*) "iter",iter," diffmax",diffmax + if (diffmax.lt.difftol) goto 10 + do i=1,dimen + Td(i)=0.0d0 + do j=1,nbond + Td(i)=Td(i)+ppvec(j)*Tmat(i,j) + enddo + enddo + do i=1,dimen + zapas(i)=Td(i) + do j=1,dimen + zapas(i)=zapas(i)+Pmat(i,j)*dc_work(j) + enddo + enddo + do j=1,3 + dc(j,0)=zapas(j) + dc_work(j)=zapas(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=zapas(ind+j) + dc_work(ind+j)=zapas(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + dc(j,i+nres)=zapas(ind+j) + dc_work(ind+j)=zapas(ind+j) + enddo + ind=ind+3 + endif + enddo +! Building the chain from the newly calculated coordinates + call chainbuild_cart + if(ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "Cartesian and internal coordinates: step 1" + call cartprint + call intout + write (iout,'(a)') "Potential forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(-gcart(j,i),j=1,3),& + (-gxcart(j,i),j=1,3) + enddo + write (iout,'(a)') "Stochastic forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(stochforc(j,i),j=1,3),& + (stochforc(j,i+nres),j=1,3) + enddo + write (iout,'(a)') "Velocities" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif + if (lprn) then + write (iout,*) "After correction for rotational lengthening" + write (iout,*) "New coordinates",& + " and differences between actual and standard bond lengths" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + xx=vbld(i+1)-vbl + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i),j=1,3),xx + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + xx=vbld(i+nres)-vbldsc0(1,itype(i)) + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i+nres),j=1,3),xx + endif + enddo + endif +! ENDDO +! write (iout,*) "Too many attempts at correcting the bonds" +! stop + 10 continue +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif +! Calculate energy and forces + call zerograd + call etotal(potEcomp) + potE=potEcomp(0)-potEcomp(20) + call cartgrad + totT=totT+d_time +! Calculate the kinetic and total energy and the kinetic temperature + call kinetic(EK) +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif + totE=EK+potE + kinetic_T=2.0d0/(dimen*Rb)*EK + return + end subroutine brown_step +!----------------------------------------------------------------------------- +! gauss.f +!----------------------------------------------------------------------------- + subroutine gauss(RO,AP,MT,M,N,*) +! +! CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION +! RO IS A SQUARE MATRIX +! THE CALCULATED PRODUCT IS STORED IN AP +! ABNORMAL EXIT IF RO IS SINGULAR +! + integer :: MT, M, N, M1,I,J,IM,& + I1,MI,MI1 + real(kind=8) :: RO(MT,M),AP(MT,N),X,RM,PR,Y + integer :: k +! real(kind=8) :: + + if(M.ne.1)goto 10 + X=RO(1,1) + if(dabs(X).le.1.0D-13) return 1 + X=1.0/X + do 16 I=1,N +16 AP(1,I)=AP(1,I)*X + return +10 continue + M1=M-1 + DO 1 I=1,M1 + IM=I + RM=DABS(RO(I,I)) + I1=I+1 + do 2 J=I1,M + if(DABS(RO(J,I)).LE.RM) goto 2 + RM=DABS(RO(J,I)) + IM=J +2 continue + If(IM.eq.I)goto 17 + do 3 J=1,N + PR=AP(I,J) + AP(I,J)=AP(IM,J) +3 AP(IM,J)=PR + do 4 J=I,M + PR=RO(I,J) + RO(I,J)=RO(IM,J) +4 RO(IM,J)=PR +17 X=RO(I,I) + if(dabs(X).le.1.0E-13) return 1 + X=1.0/X + do 5 J=1,N +5 AP(I,J)=X*AP(I,J) + do 6 J=I1,M +6 RO(I,J)=X*RO(I,J) + do 7 J=I1,M + Y=RO(J,I) + do 8 K=1,N +8 AP(J,K)=AP(J,K)-Y*AP(I,K) + do 9 K=I1,M +9 RO(J,K)=RO(J,K)-Y*RO(I,K) +7 continue +1 continue + X=RO(M,M) + if(dabs(X).le.1.0E-13) return 1 + X=1.0/X + do 11 J=1,N +11 AP(M,J)=X*AP(M,J) + do 12 I=1,M1 + MI=M-I + MI1=MI+1 + do 14 J=1,N + X=AP(MI,J) + do 15 K=MI1,M +15 X=X-AP(K,J)*RO(MI,K) +14 AP(MI,J)=X +12 continue + return + end subroutine gauss +!----------------------------------------------------------------------------- +! kinetic_lesyng.f +!----------------------------------------------------------------------------- + subroutine kinetic(KE_total) +!---------------------------------------------------------------- +! This subroutine calculates the total kinetic energy of the chain +!----------------------------------------------------------------- + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' + real(kind=8) :: KE_total + + integer :: i,j,k,iti + real(kind=8) :: KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3),& + mag1,mag2,v(3) + + KEt_p=0.0d0 + KEt_sc=0.0d0 +! write (iout,*) "ISC",(isc(itype(i)),i=1,nres) +! The translational part for peptide virtual bonds + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 +! write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +! write(iout,*) 'KEt_p', KEt_p +! The translational part for the side chain virtual bond +! Only now we can initialize incr with zeros. It must be equal +! to the velocities of the first Calpha. + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).eq.10) then + do j=1,3 + v(j)=incr(j) + enddo + else + do j=1,3 + v(j)=incr(j)+d_t(j,nres+i) + enddo + endif +! write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) +! write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) + KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +! goto 111 +! write(iout,*) 'KEt_sc', KEt_sc +! The part due to stretching and rotation of the peptide groups + KEr_p=0.0D0 + do i=nnt,nct-1 +! write (iout,*) "i",i +! write (iout,*) "i",i," mag1",mag1," mag2",mag2 + do j=1,3 + incr(j)=d_t(j,i) + enddo +! write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) + KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) & + +incr(3)*incr(3)) + enddo +! goto 111 +! write(iout,*) 'KEr_p', KEr_p +! The rotational part of the side chain virtual bond + KEr_sc=0.0D0 + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).ne.10) then + do j=1,3 + incr(j)=d_t(j,nres+i) + enddo +! write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) + KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ & + incr(3)*incr(3)) + endif + enddo +! The total kinetic energy + 111 continue +! write(iout,*) 'KEr_sc', KEr_sc + KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) +! write (iout,*) "KE_total",KE_total + return + end subroutine kinetic +!----------------------------------------------------------------------------- +! MD_A-MTS.F +!----------------------------------------------------------------------------- + subroutine MD +!------------------------------------------------ +! The driver for molecular dynamics subroutines +!------------------------------------------------ + use comm_gucio +! use MPI + use control, only:tcpu,ovrtim +! use io_comm, only:ilen + use control_data + use compare, only:secondary2,hairpin + use io, only:cartout,statout +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +! include 'COMMON.HAIRPIN' + real(kind=8),dimension(3) :: L,vcm +#ifdef VOUT + real(kind=8),dimension(6*nres) :: v_work,v_transf !(maxres6) maxres6=6*maxres +#endif + integer :: rstcount !ilen, +!el external ilen + character(len=50) :: tytul +!el common /gucio/ cm + integer :: itime,i,j,nharp + integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) +! logical :: ovrtim + real(kind=8) :: tt0,scalfac + integer :: nres2 + nres2=2*nres +! +#ifdef MPI + if (ilen(tmpdir).gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" & + //liczba(:ilen(liczba))//'.rst') +#else + if (ilen(tmpdir).gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') +#endif + t_MDsetup=0.0d0 + t_langsetup=0.0d0 + t_MD=0.0d0 + t_enegrad=0.0d0 + t_sdsetup=0.0d0 + write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" +#ifdef MPI + tt0=MPI_Wtime() +#else + tt0 = tcpu() +#endif +! Determine the inverse of the inertia matrix. + call setup_MD_matrices +! Initialize MD + call init_MD +#ifdef MPI + t_MDsetup = MPI_Wtime()-tt0 +#else + t_MDsetup = tcpu()-tt0 +#endif + rstcount=0 +! Entering the MD loop +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#else + write (iout,*) & + "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif +#ifdef MPI + t_langsetup=MPI_Wtime()-tt0 + tt0=MPI_Wtime() +#else + t_langsetup=tcpu()-tt0 + tt0=tcpu() +#endif + do itime=1,n_timestep + if (ovrtim()) exit + if (large.and. mod(itime,ntwe).eq.0) & + write (iout,*) "itime",itime + rstcount=rstcount+1 + if (lang.gt.0 .and. surfarea .and. & + mod(itime,reset_fricmat).eq.0) then + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif + write (iout,'(a,i10)') & + "Friction matrix reset based on surface area, itime",itime + endif + if (reset_vel .and. tbf .and. lang.eq.0 & + .and. mod(itime,count_reset_vel).eq.0) then + call random_vel + write(iout,'(a,f20.2)') & + "Velocities reset to random values, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + enddo + enddo + endif + if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then + call inertia_tensor + call vcm_vel(vcm) + do j=1,3 + d_t(j,0)=d_t(j,0)-vcm(j) + enddo + call kinetic(EK) + kinetic_T=2.0d0/(dimen3*Rb)*EK + scalfac=dsqrt(T_bath/kinetic_T) + write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=scalfac*d_t(j,i) + enddo + enddo + endif + if (lang.ne.4) then + if (RESPA) then +! Time-reversible RESPA algorithm +! (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) + call RESPA_step(itime) + else +! Variable time step algorithm. + call velverlet_step(itime) + endif + else +#ifdef BROWN + call brown_step(itime) +#else + print *,"Brown dynamics not here!" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0) call statout(itime) +#ifdef VOUT + do j=1,3 + v_work(j)=d_t(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + v_work(ind)=d_t(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + ind=ind+1 + v_work(ind)=d_t(j,i+nres) + enddo + endif + enddo + + write (66,'(80f10.5)') & + ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) + do i=1,ind + v_transf(i)=0.0d0 + do j=1,ind + v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) + enddo + v_transf(i)= v_transf(i)*dsqrt(geigen(i)) + enddo + write (67,'(80f10.5)') (v_transf(i),i=1,ind) +#endif + endif + if (mod(itime,ntwx).eq.0) then + write (tytul,'("time",f8.2)') totT + if(mdpdb) then + call hairpin(.true.,nharp,iharp) + call secondary2(.true.) + call pdbout(potE,tytul,ipdb) + else + call cartout(totT) + endif + endif + if (rstcount.eq.1000.or.itime.eq.n_timestep) then + open(irest2,file=rest2name,status='unknown') + write(irest2,*) totT,EK,potE,totE,t_bath + do i=1,2*nres + write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) + enddo + do i=1,2*nres + write (irest2,'(3e15.5)') (dc(j,i),j=1,3) + enddo + close(irest2) + rstcount=0 + endif + enddo + +#ifdef MPI + t_MD=MPI_Wtime()-tt0 +#else + t_MD=tcpu()-tt0 +#endif + write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') & + ' Timing ',& + 'MD calculations setup:',t_MDsetup,& + 'Energy & gradient evaluation:',t_enegrad,& + 'Stochastic MD setup:',t_langsetup,& + 'Stochastic MD step setup:',t_sdsetup,& + 'MD steps:',t_MD + write (iout,'(/28(1h=),a25,27(1h=))') & + ' End of MD calculation ' +#ifdef TIMING_ENE + write (iout,*) "time for etotal",t_etotal," elong",t_elong,& + " eshort",t_eshort + write (iout,*) "time_fric",time_fric," time_stoch",time_stoch,& + " time_fricmatmult",time_fricmatmult," time_fsample ",& + time_fsample +#endif + return + end subroutine MD +!----------------------------------------------------------------------------- + subroutine velverlet_step(itime) +!------------------------------------------------------------------------------- +! Perform a single velocity Verlet step; the time step can be rescaled if +! increments in accelerations exceed the threshold +!------------------------------------------------------------------------------- +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use comm_gucio + use control, only:tcpu + use control_data +#ifdef MPI + include 'mpif.h' + integer :: ierror,ierrcode + real(kind=8) :: errcode +#endif +! include 'COMMON.SETUP' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +! include 'COMMON.MUCA' + real(kind=8),dimension(3) :: vcm,incr + real(kind=8),dimension(3) :: L + integer :: count,rstcount !ilen, +!el external ilen + character(len=50) :: tytul + integer :: maxcount_scale = 20 +!el common /gucio/ cm +!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec + integer :: itime,icount_scale,itime_scal,i,j,ifac_time + logical :: scale + real(kind=8) :: epdrift,tt0,fac_time +! + if (.not.allocated(stochforcvec)) allocate(stochforcvec(6*nres)) !(MAXRES6) maxres6=6*maxres + + scale=.true. + icount_scale=0 + if (lang.eq.1) then + call sddir_precalc + else if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call stochastic_force(stochforcvec) +#else + write (iout,*) & + "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif + itime_scal=0 + do while (scale) + icount_scale=icount_scale+1 + if (icount_scale.gt.maxcount_scale) then + write (iout,*) & + "ERROR: too many attempts at scaling down the time step. ",& + "amax=",amax,"epdrift=",epdrift,& + "damax=",damax,"edriftmax=",edriftmax,& + "d_time=",d_time + call flush(iout) +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) +#endif + stop + endif +! First step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet1 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet1_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet1 + else + call verlet1 + endif +! Build the chain from the newly calculated coordinates + call chainbuild_cart + if (rattle) call rattle1 + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "Cartesian and internal coordinates: step 1" + call cartprint + call intout + write (iout,*) "dC" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),& + (dc(j,i+nres),j=1,3) + enddo + write (iout,*) "Accelerations" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + write (iout,*) "Velocities, step 1" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +! Calculate energy and forces + call zerograd + call etotal(potEcomp) + if (large.and. mod(itime,ntwe).eq.0) & + call enerprint(potEcomp) +#ifdef TIMING_ENE +#ifdef MPI + t_etotal=t_etotal+MPI_Wtime()-tt0 +#else + t_etotal=t_etotal+tcpu()-tt0 +#endif +#endif + potE=potEcomp(0)-potEcomp(20) + call cartgrad +! Get the new accelerations + call lagrangian +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif +! Determine maximum acceleration and scale down the timestep if needed + call max_accel + amax=amax/(itime_scal+1)**2 + call predict_edrift(epdrift) + if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then +! Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step + scale=.true. + ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) & + /dlog(2.0d0)+1 + itime_scal=itime_scal+ifac_time +! fac_time=dmin1(damax/amax,0.5d0) + fac_time=0.5d0**ifac_time + d_time=d_time*fac_time + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 +! write (iout,*) "Calling sd_verlet_setup: 1" +! Rescale the stochastic forces and recalculate or restore +! the matrices of tinker integrator + if (itime_scal.gt.maxflag_stoch) then + if (large) write (iout,'(a,i5,a)') & + "Calculate matrices for stochastic step;",& + " itime_scal ",itime_scal + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + write (iout,'(2a,i3,a,i3,1h.)') & + "Warning: cannot store matrices for stochastic",& + " integration because the index",itime_scal,& + " is greater than",maxflag_stoch + write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct",& + " integration Langevin algorithm for better efficiency." + else if (flag_stoch(itime_scal)) then + if (large) write (iout,'(a,i5,a,l1)') & + "Restore matrices for stochastic step; itime_scal ",& + itime_scal," flag ",flag_stoch(itime_scal) + do i=1,dimen + do j=1,dimen + pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) + afric_mat(i,j)=afric0_mat(i,j,itime_scal) + vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) + prand_mat(i,j)=prand0_mat(i,j,itime_scal) + vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) + vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) + enddo + enddo + else + if (large) write (iout,'(2a,i5,a,l1)') & + "Calculate & store matrices for stochastic step;",& + " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + flag_stoch(ifac_time)=.true. + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) + afric0_mat(i,j,itime_scal)=afric_mat(i,j) + vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) + prand0_mat(i,j,itime_scal)=prand_mat(i,j) + vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) + vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) + enddo + enddo + endif + fac_time=1.0d0/dsqrt(fac_time) + do i=1,dimen + stochforcvec(i)=fac_time*stochforcvec(i) + enddo +#endif + else if (lang.eq.1) then +! Rescale the accelerations due to stochastic forces + fac_time=1.0d0/dsqrt(fac_time) + do i=1,dimen + d_as_work(i)=d_as_work(i)*fac_time + enddo + endif + if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') & + "itime",itime," Timestep scaled down to ",& + d_time," ifac_time",ifac_time," itime_scal",itime_scal + else +! Second step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet2 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet2_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet2 + else + call verlet2 + endif + if (rattle) call rattle2 + totT=totT+d_time + if (d_time.ne.d_time0) then + d_time=d_time0 +#ifndef LANG0 + if (lang.eq.2 .or. lang.eq.3) then + if (large) write (iout,'(a)') & + "Restore original matrices for stochastic step" +! write (iout,*) "Calling sd_verlet_setup: 2" +! Restore the matrices of tinker integrator if the time step has been restored + do i=1,dimen + do j=1,dimen + pfric_mat(i,j)=pfric0_mat(i,j,0) + afric_mat(i,j)=afric0_mat(i,j,0) + vfric_mat(i,j)=vfric0_mat(i,j,0) + prand_mat(i,j)=prand0_mat(i,j,0) + vrand_mat1(i,j)=vrand0_mat1(i,j,0) + vrand_mat2(i,j)=vrand0_mat2(i,j,0) + enddo + enddo + endif +#endif + endif + scale=.false. + endif + enddo +! Calculate the kinetic and the total energy and the kinetic temperature + call kinetic(EK) + totE=EK+potE +! diagnostics +! call kinetic1(EK1) +! write (iout,*) "step",itime," EK",EK," EK1",EK1 +! end diagnostics +! Couple the system to Berendsen bath if needed + if (tbf .and. lang.eq.0) then + call verlet_bath + endif + kinetic_T=2.0d0/(dimen3*Rb)*EK +! Backup the coordinates, velocities, and accelerations + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo + enddo + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0 .and. large) then + write (iout,*) "Velocities, step 2" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif + return + end subroutine velverlet_step +!----------------------------------------------------------------------------- + subroutine RESPA_step(itime) +!------------------------------------------------------------------------------- +! Perform a single RESPA step. +!------------------------------------------------------------------------------- +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use comm_gucio + use comm_cipiszcze +! use MPI + use control, only:tcpu + use control_data +! use io_conf, only:cartprint +#ifdef MPI + include 'mpif.h' + integer :: IERROR,ERRCODE +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8),dimension(0:n_ene) :: energia_short,energia_long + real(kind=8),dimension(3) :: L,vcm,incr + real(kind=8),dimension(3,0:2*nres) :: dc_old0,d_t_old0,d_a_old0 !(3,0:maxres2) maxres2=2*maxres + logical :: PRINT_AMTS_MSG = .false. + integer :: count,rstcount !ilen, +!el external ilen + character(len=50) :: tytul + integer :: maxcount_scale = 10 +!el common /gucio/ cm +!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec + integer :: itime,itt,i,j,itsplit + logical :: scale +!el common /cipiszcze/ itt + + real(kind=8) :: epdrift,tt0,epdriftmax + itt = itt_comm + + if (.not.allocated(stochforcvec)) allocate(stochforcvec(6*nres)) !(MAXRES6) maxres6=6*maxres + + itt=itime + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "***************** RESPA itime",itime + write (iout,*) "Cartesian and internal coordinates: step 0" +! call cartprint + call pdbout(0.0d0,"cipiszcze",iout) + call intout + write (iout,*) "Accelerations from long-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + write (iout,*) "Velocities, step 0" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif +! +! Perform the initial RESPA step (increment velocities) +! write (iout,*) "*********************** RESPA ini" + call RESPA_vel + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0 .and. large) then + write (iout,*) "Velocities, end" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif +! Compute the short-range forces +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif +! 7/2/2009 commented out +! call zerograd +! call etotal_short(energia_short) +! call cartgrad +! call lagrangian +! 7/2/2009 Copy accelerations due to short-lange forces from previous MD step + do i=0,2*nres + do j=1,3 + d_a(j,i)=d_a_short(j,i) + enddo + enddo + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "energia_short",energia_short(0) + write (iout,*) "Accelerations from short-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + endif + endif +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo + enddo +! 6/30/08 A-MTS: attempt at increasing the split number + do i=0,2*nres + do j=1,3 + dc_old0(j,i)=dc_old(j,i) + d_t_old0(j,i)=d_t_old(j,i) + d_a_old0(j,i)=d_a_old(j,i) + enddo + enddo + if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 + if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 +! + scale=.true. + d_time0=d_time + do while (scale) + + scale=.false. +! write (iout,*) "itime",itime," ntime_split",ntime_split +! Split the time step + d_time=d_time0/ntime_split +! Perform the short-range RESPA steps (velocity Verlet increments of +! positions and velocities using short-range forces) +! write (iout,*) "*********************** RESPA split" + do itsplit=1,ntime_split + if (lang.eq.1) then + call sddir_precalc + else if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call stochastic_force(stochforcvec) +#else + write (iout,*) & + "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif +! First step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet1 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet1_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet1 + else + call verlet1 + endif +! Build the chain from the newly calculated coordinates + call chainbuild_cart + if (rattle) call rattle1 + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "***** ITSPLIT",itsplit + write (iout,*) "Cartesian and internal coordinates: step 1" + call pdbout(0.0d0,"cipiszcze",iout) +! call cartprint + call intout + write (iout,*) "Velocities, step 1" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +! Calculate energy and forces + call zerograd + call etotal_short(energia_short) + if (large.and. mod(itime,ntwe).eq.0) & + call enerprint(energia_short) +#ifdef TIMING_ENE +#ifdef MPI + t_eshort=t_eshort+MPI_Wtime()-tt0 +#else + t_eshort=t_eshort+tcpu()-tt0 +#endif +#endif + call cartgrad +! Get the new accelerations + call lagrangian +! 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array + do i=0,2*nres + do j=1,3 + d_a_short(j,i)=d_a(j,i) + enddo + enddo + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*)"energia_short",energia_short(0) + write (iout,*) "Accelerations from short-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + endif + endif +! 6/30/08 A-MTS +! Determine maximum acceleration and scale down the timestep if needed + call max_accel + amax=amax/ntime_split**2 + call predict_edrift(epdrift) + if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) & + write (iout,*) "amax",amax," damax",damax,& + " epdrift",epdrift," epdriftmax",epdriftmax +! Exit loop and try with increased split number if the change of +! acceleration is too big + if (amax.gt.damax .or. epdrift.gt.edriftmax) then + if (ntime_split.lt.maxtime_split) then + scale=.true. + ntime_split=ntime_split*2 + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc_old0(j,i) + d_t_old(j,i)=d_t_old0(j,i) + d_a_old(j,i)=d_a_old0(j,i) + enddo + enddo + if (PRINT_AMTS_MSG) then + write (iout,*) "acceleration/energy drift too large",amax,& + epdrift," split increased to ",ntime_split," itime",itime,& + " itsplit",itsplit + endif + exit + else + write (iout,*) & + "Uh-hu. Bumpy landscape. Maximum splitting number",& + maxtime_split,& + " already reached!!! Trying to carry on!" + endif + endif +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif +! Second step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet2 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet2_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet2 + else + call verlet2 + endif + if (rattle) call rattle2 +! Backup the coordinates, velocities, and accelerations + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo + enddo + enddo + + enddo ! while scale + +! Restore the time step + d_time=d_time0 +! Compute long-range forces +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif + call zerograd + call etotal_long(energia_long) + if (large.and. mod(itime,ntwe).eq.0) & + call enerprint(energia_long) +#ifdef TIMING_ENE +#ifdef MPI + t_elong=t_elong+MPI_Wtime()-tt0 +#else + t_elong=t_elong+tcpu()-tt0 +#endif +#endif + call cartgrad + call lagrangian +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif +! Compute accelerations from long-range forces + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "energia_long",energia_long(0) + write (iout,*) "Cartesian and internal coordinates: step 2" +! call cartprint + call pdbout(0.0d0,"cipiszcze",iout) + call intout + write (iout,*) "Accelerations from long-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + write (iout,*) "Velocities, step 2" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif +! Compute the final RESPA step (increment velocities) +! write (iout,*) "*********************** RESPA fin" + call RESPA_vel +! Compute the complete potential energy + do i=0,n_ene + potEcomp(i)=energia_short(i)+energia_long(i) + enddo + potE=potEcomp(0)-potEcomp(20) +! potE=energia_short(0)+energia_long(0) + totT=totT+d_time +! Calculate the kinetic and the total energy and the kinetic temperature + call kinetic(EK) + totE=EK+potE +! Couple the system to Berendsen bath if needed + if (tbf .and. lang.eq.0) then + call verlet_bath + endif + kinetic_T=2.0d0/(dimen3*Rb)*EK +! Backup the coordinates, velocities, and accelerations + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0 .and. large) then + write (iout,*) "Velocities, end" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + endif + endif + return + end subroutine RESPA_step +!----------------------------------------------------------------------------- + subroutine RESPA_vel +! First and last RESPA step (incrementing velocities using long-range +! forces). + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + integer :: i,j,inres + + do j=1,3 + d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time + enddo + endif + enddo + return + end subroutine RESPA_vel +!----------------------------------------------------------------------------- + subroutine verlet1 +! Applying velocity Verlet algorithm - step 1 to coordinates + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + real(kind=8) :: adt,adt2 + integer :: i,j,inres + +#ifdef DEBUG + write (iout,*) "VELVERLET1 START: DC" + do i=0,nres + write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),& + (dc(j,i+nres),j=1,3) + enddo +#endif + do j=1,3 + adt=d_a_old(j,0)*d_time + adt2=0.5d0*adt + dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time + d_t_new(j,0)=d_t_old(j,0)+adt2 + d_t(j,0)=d_t_old(j,0)+adt + enddo + do i=nnt,nct-1 + do j=1,3 + adt=d_a_old(j,i)*d_time + adt2=0.5d0*adt + dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time + d_t_new(j,i)=d_t_old(j,i)+adt2 + d_t(j,i)=d_t_old(j,i)+adt + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + adt=d_a_old(j,inres)*d_time + adt2=0.5d0*adt + dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time + d_t_new(j,inres)=d_t_old(j,inres)+adt2 + d_t(j,inres)=d_t_old(j,inres)+adt + enddo + endif + enddo +#ifdef DEBUG + write (iout,*) "VELVERLET1 END: DC" + do i=0,nres + write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),& + (dc(j,i+nres),j=1,3) + enddo +#endif + return + end subroutine verlet1 +!----------------------------------------------------------------------------- + subroutine verlet2 +! Step 2 of the velocity Verlet algorithm: update velocities + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + integer :: i,j,inres + + do j=1,3 + d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time + enddo + endif + enddo + return + end subroutine verlet2 +!----------------------------------------------------------------------------- + subroutine sddir_precalc +! Applying velocity Verlet algorithm - step 1 to coordinates +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use MPI_data + use control_data +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec + real(kind=8) :: time00 +! +! Compute friction and stochastic forces +! +#ifdef MPI + time00=MPI_Wtime() + call friction_force + time_fric=time_fric+MPI_Wtime()-time00 + time00=MPI_Wtime() + call stochastic_force(stochforcvec) + time_stoch=time_stoch+MPI_Wtime()-time00 +#endif +! +! Compute the acceleration due to friction forces (d_af_work) and stochastic +! forces (d_as_work) +! + call ginv_mult(fric_work, d_af_work) + call ginv_mult(stochforcvec, d_as_work) + return + end subroutine sddir_precalc +!----------------------------------------------------------------------------- + subroutine sddir_verlet1 +! Applying velocity Verlet algorithm - step 1 to velocities +! + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! Revised 3/31/05 AL: correlation between random contributions to +! position and velocity increments included. + real(kind=8) :: sqrt13 = 0.57735026918962576451d0 ! 1/sqrt(3) + real(kind=8) :: adt,adt2 + integer :: i,j,ind,inres +! +! Add the contribution from BOTH friction and stochastic force to the +! coordinates, but ONLY the contribution from the friction forces to velocities +! + do j=1,3 + adt=(d_a_old(j,0)+d_af_work(j))*d_time + adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time + dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time + d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt + d_t(j,0)=d_t_old(j,0)+adt + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time + adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time + dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time + d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt + d_t(j,i)=d_t_old(j,i)+adt + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time + adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time + dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time + d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt + d_t(j,inres)=d_t_old(j,inres)+adt + enddo + ind=ind+3 + endif + enddo + return + end subroutine sddir_verlet1 +!----------------------------------------------------------------------------- + subroutine sddir_verlet2 +! Calculating the adjusted velocities for accelerations +! + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + real(kind=8),dimension(6*nres) :: stochforcvec,d_as_work1 !(MAXRES6) maxres6=6*maxres + real(kind=8) :: cos60 = 0.5d0, sin60 = 0.86602540378443864676d0 + integer :: i,j,ind,inres +! Revised 3/31/05 AL: correlation between random contributions to +! position and velocity increments included. +! The correlation coefficients are calculated at low-friction limit. +! Also, friction forces are now not calculated with new velocities. + +! call friction_force + call stochastic_force(stochforcvec) +! +! Compute the acceleration due to friction forces (d_af_work) and stochastic +! forces (d_as_work) +! + call ginv_mult(stochforcvec, d_as_work1) + +! +! Update velocities +! + do j=1,3 + d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) & + +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) & + +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) & + +d_af_work(ind+j))+sin60*d_as_work(ind+j) & + +cos60*d_as_work1(ind+j))*d_time + enddo + ind=ind+3 + endif + enddo + return + end subroutine sddir_verlet2 +!----------------------------------------------------------------------------- + subroutine max_accel +! +! Find the maximum difference in the accelerations of the the sites +! at the beginning and the end of the time step. +! + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' + real(kind=8),dimension(3) :: aux,accel,accel_old + real(kind=8) :: dacc + integer :: i,j + + do j=1,3 +! aux(j)=d_a(j,0)-d_a_old(j,0) + accel_old(j)=d_a_old(j,0) + accel(j)=d_a(j,0) + enddo + amax=0.0d0 + do i=nnt,nct +! Backbone + if (i.lt.nct) then +! 7/3/08 changed to asymmetric difference + do j=1,3 +! accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) + accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) + accel(j)=accel(j)+0.5d0*d_a(j,i) +! if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) + if (dabs(accel(j)).gt.dabs(accel_old(j))) then + dacc=dabs(accel(j)-accel_old(j)) +! write (iout,*) i,dacc + if (dacc.gt.amax) amax=dacc + endif + enddo + endif + enddo +! Side chains + do j=1,3 +! accel(j)=aux(j) + accel_old(j)=d_a_old(j,0) + accel(j)=d_a(j,0) + enddo + if (nnt.eq.2) then + do j=1,3 + accel_old(j)=accel_old(j)+d_a_old(j,1) + accel(j)=accel(j)+d_a(j,1) + enddo + endif + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 +! accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) + accel_old(j)=accel_old(j)+d_a_old(j,i+nres) + accel(j)=accel(j)+d_a(j,i+nres) + enddo + endif + do j=1,3 +! if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) + if (dabs(accel(j)).gt.dabs(accel_old(j))) then + dacc=dabs(accel(j)-accel_old(j)) +! write (iout,*) "side-chain",i,dacc + if (dacc.gt.amax) amax=dacc + endif + enddo + do j=1,3 + accel_old(j)=accel_old(j)+d_a_old(j,i) + accel(j)=accel(j)+d_a(j,i) +! aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) + enddo + enddo + return + end subroutine max_accel +!----------------------------------------------------------------------------- + subroutine predict_edrift(epdrift) +! +! Predict the drift of the potential energy +! + use energy_data + use control_data, only: lmuca +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.MUCA' + real(kind=8) :: epdrift,epdriftij + integer :: i,j +! Drift of the potential energy + epdrift=0.0d0 + do i=nnt,nct +! Backbone + if (i.lt.nct) then + do j=1,3 + epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) + if (lmuca) epdriftij=epdriftij*factor +! write (iout,*) "back",i,j,epdriftij + if (epdriftij.gt.epdrift) epdrift=epdriftij + enddo + endif +! Side chains + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + epdriftij= & + dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) + if (lmuca) epdriftij=epdriftij*factor +! write (iout,*) "side",i,j,epdriftij + if (epdriftij.gt.epdrift) epdrift=epdriftij + enddo + endif + enddo + epdrift=0.5d0*epdrift*d_time*d_time +! write (iout,*) "epdrift",epdrift + return + end subroutine predict_edrift +!----------------------------------------------------------------------------- + subroutine verlet_bath +! +! Coupling to the thermostat by using the Berendsen algorithm +! + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + real(kind=8) :: T_half,fact + integer :: i,j,inres +! + T_half=2.0d0/(dimen3*Rb)*EK + fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) +! write(iout,*) "T_half", T_half +! write(iout,*) "EK", EK +! write(iout,*) "fact", fact + do j=1,3 + d_t(j,0)=fact*d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=fact*d_t(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + d_t(j,inres)=fact*d_t(j,inres) + enddo + endif + enddo + return + end subroutine verlet_bath +!----------------------------------------------------------------------------- + subroutine init_MD +! Set up the initial conditions of a MD simulation + use comm_gucio + use energy_data + use control, only:tcpu +!el use io_basic, only:ilen + use control_data + use MPI_data + use minimm, only:minim_dc,minimize,sc_move + use io_config, only:readrst + use io, only:statout +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MP + include 'mpif.h' + character(len=16) :: form + integer :: IERROR,ERRCODE +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.REMD' + real(kind=8),dimension(0:n_ene) :: energia_long,energia_short + real(kind=8),dimension(3) :: vcm,incr,L + real(kind=8) :: xv,sigv,lowb,highb + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + character(len=256) :: qstr +!el integer ilen +!el external ilen + character(len=50) :: tytul + logical :: file_exist +!el common /gucio/ cm + integer :: i,j,ipos,iq,iw,nft_sc,iretcode,nfun,itime,ierr + real(kind=8) :: etot,tt0 + logical :: fail + + d_time0=d_time +! write(iout,*) "d_time", d_time +! Compute the standard deviations of stochastic forces for Langevin dynamics +! if the friction coefficients do not depend on surface area + if (lang.gt.0 .and. .not.surfarea) then + do i=nnt,nct-1 + stdforcp(i)=stdfp*dsqrt(gamp) + enddo + do i=nnt,nct + stdforcsc(i)=stdfsc(iabs(itype(i))) & + *dsqrt(gamsc(iabs(itype(i)))) + enddo + endif +! Open the pdb file for snapshotshots +#ifdef MPI + if(mdpdb) then + if (ilen(tmpdir).gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// & + liczba(:ilen(liczba))//".pdb") + open(ipdb,& + file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) & + //".pdb") + else +#ifdef NOXDR + if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// & + liczba(:ilen(liczba))//".x") + cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) & + //".x" +#else + if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// & + liczba(:ilen(liczba))//".cx") + cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) & + //".cx" +#endif + endif +#else + if(mdpdb) then + if (ilen(tmpdir).gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") + open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") + else + if (ilen(tmpdir).gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") + cartname=prefix(:ilen(prefix))//"_MD.cx" + endif +#endif + if (usampl) then + write (qstr,'(256(1h ))') + ipos=1 + do i=1,nfrag + iq = qinfrag(i,iset)*10 + iw = wfrag(i,iset)/100 + if (iw.gt.0) then + if(me.eq.king.or..not.out1file) & + write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw + write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw + ipos=ipos+7 + endif + enddo + do i=1,npair + iq = qinpair(i,iset)*10 + iw = wpair(i,iset)/100 + if (iw.gt.0) then + if(me.eq.king.or..not.out1file) & + write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw + write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw + ipos=ipos+7 + endif + enddo +! pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' +#ifdef NOXDR +! cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' +#else +! cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' +#endif +! statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' + endif + icg=1 + if (rest) then + if (restart1file) then + if (me.eq.king) & + inquire(file=mremd_rst_name,exist=file_exist) + write (*,*) me," Before broadcast: file_exist",file_exist +#ifdef MPI !el + call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,& + IERR) +#endif !el + write (*,*) me," After broadcast: file_exist",file_exist +! inquire(file=mremd_rst_name,exist=file_exist) + if(me.eq.king.or..not.out1file) & + write(iout,*) "Initial state read by master and distributed" + else + if (ilen(tmpdir).gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' & + //liczba(:ilen(liczba))//'.rst') + inquire(file=rest2name,exist=file_exist) + endif + if(file_exist) then + if(.not.restart1file) then + if(me.eq.king.or..not.out1file) & + write(iout,*) "Initial state will be read from file ",& + rest2name(:ilen(rest2name)) + call readrst + endif + call rescale_weights(t_bath) + else + if(me.eq.king.or..not.out1file)then + if (restart1file) then + write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)),& + " does not exist" + else + write(iout,*) "File ",rest2name(:ilen(rest2name)),& + " does not exist" + endif + write(iout,*) "Initial velocities randomly generated" + endif + call random_vel + totT=0.0d0 + endif + else +! Generate initial velocities + if(me.eq.king.or..not.out1file) & + write(iout,*) "Initial velocities randomly generated" + call random_vel + totT=0.0d0 + endif +! rest2name = prefix(:ilen(prefix))//'.rst' + if(me.eq.king.or..not.out1file)then + write (iout,*) "Initial velocities" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo +! Zeroing the total angular momentum of the system + write(iout,*) "Calling the zero-angular momentum subroutine" + endif + call inertia_tensor +! Getting the potential energy and forces and velocities and accelerations + call vcm_vel(vcm) +! write (iout,*) "velocity of the center of the mass:" +! write (iout,*) (vcm(j),j=1,3) + do j=1,3 + d_t(j,0)=d_t(j,0)-vcm(j) + enddo +! Removing the velocity of the center of mass + call vcm_vel(vcm) + if(me.eq.king.or..not.out1file)then + write (iout,*) "vcm right after adjustment:" + write (iout,*) (vcm(j),j=1,3) + endif + if (.not.rest) then + call chainbuild + if(iranconf.ne.0) then + if (overlapsc) then + print *, 'Calling OVERLAP_SC' + call overlap_sc(fail) + endif + if (searchsc) then + call sc_move(2,nres-1,10,1d10,nft_sc,etot) + print *,'SC_move',nft_sc,etot + if(me.eq.king.or..not.out1file) & + write(iout,*) 'SC_move',nft_sc,etot + endif + + if(dccart)then + print *, 'Calling MINIM_DC' + call minim_dc(etot,iretcode,nfun) + else + call geom_to_var(nvar,varia) + print *,'Calling MINIMIZE.' + call minimize(etot,varia,iretcode,nfun) + call var_to_geom(nvar,varia) + endif + if(me.eq.king.or..not.out1file) & + write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun + endif + endif + call chainbuild_cart + call kinetic(EK) + if (tbf) then + call verlet_bath + endif + kinetic_T=2.0d0/(dimen3*Rb)*EK + if(me.eq.king.or..not.out1file)then + call cartprint + call intout + endif +#ifdef MPI + tt0=MPI_Wtime() +#else + tt0=tcpu() +#endif + call zerograd + call etotal(potEcomp) + if (large) call enerprint(potEcomp) +#ifdef TIMING_ENE +#ifdef MPI + t_etotal=t_etotal+MPI_Wtime()-tt0 +#else + t_etotal=t_etotal+tcpu()-tt0 +#endif +#endif + potE=potEcomp(0) + call cartgrad + call lagrangian + call max_accel + if (amax*d_time .gt. dvmax) then + d_time=d_time*dvmax/amax + if(me.eq.king.or..not.out1file) write (iout,*) & + "Time step reduced to",d_time,& + " because of too large initial acceleration." + endif + if(me.eq.king.or..not.out1file)then + write(iout,*) "Potential energy and its components" + call enerprint(potEcomp) +! write(iout,*) (potEcomp(i),i=0,n_ene) + endif + potE=potEcomp(0)-potEcomp(20) + totE=EK+potE + itime=0 + if (ntwe.ne.0) call statout(itime) + if(me.eq.king.or..not.out1file) & + write (iout,'(/a/3(a25,1pe14.5/))') "Initial:", & + " Kinetic energy",EK," Potential energy",potE, & + " Total energy",totE," Maximum acceleration ", & + amax + if (large) then + write (iout,*) "Initial coordinates" + do i=1,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3),& + (c(j,i+nres),j=1,3) + enddo + write (iout,*) "Initial dC" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),& + (dc(j,i+nres),j=1,3) + enddo + write (iout,*) "Initial velocities" + write (iout,"(13x,' backbone ',23x,' side chain')") + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& + (d_t(j,i+nres),j=1,3) + enddo + write (iout,*) "Initial accelerations" + do i=0,nres +! write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + endif + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo +! write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) + enddo + if (RESPA) then +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif + call zerograd + call etotal_short(energia_short) + if (large) call enerprint(potEcomp) +#ifdef TIMING_ENE +#ifdef MPI + t_eshort=t_eshort+MPI_Wtime()-tt0 +#else + t_eshort=t_eshort+tcpu()-tt0 +#endif +#endif + call cartgrad + call lagrangian + if(.not.out1file .and. large) then + write (iout,*) "energia_long",energia_long(0),& + " energia_short",energia_short(0),& + " total",energia_long(0)+energia_short(0) + write (iout,*) "Initial fast-force accelerations" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + endif +! 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array + do i=0,2*nres + do j=1,3 + d_a_short(j,i)=d_a(j,i) + enddo + enddo +#ifdef MPI + tt0=MPI_Wtime() +#else + tt0=tcpu() +#endif + call zerograd + call etotal_long(energia_long) + if (large) call enerprint(potEcomp) +#ifdef TIMING_ENE +#ifdef MPI + t_elong=t_elong+MPI_Wtime()-tt0 +#else + t_elong=t_elong+tcpu()-tt0 +#endif +#endif + call cartgrad + call lagrangian + if(.not.out1file .and. large) then + write (iout,*) "energia_long",energia_long(0) + write (iout,*) "Initial slow-force accelerations" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& + (d_a(j,i+nres),j=1,3) + enddo + endif +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif + endif + return + end subroutine init_MD +!----------------------------------------------------------------------------- + subroutine random_vel + +! implicit real*8 (a-h,o-z) + use energy_data + use random, only:anorm_distr +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8) :: xv,sigv,lowb,highb ,Ek1 + integer :: i,j,ii,k,ind +! Generate random velocities from Gaussian distribution of mean 0 and std of KT/m +! First generate velocities in the eigenspace of the G matrix +! write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 +! call flush(iout) + xv=0.0d0 + ii=0 + do i=1,dimen + do k=1,3 + ii=ii+1 + sigv=dsqrt((Rb*t_bath)/geigen(i)) + lowb=-5*sigv + highb=5*sigv + d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) +! write (iout,*) "i",i," ii",ii," geigen",geigen(i),& +! " d_t_work_new",d_t_work_new(ii) + enddo + enddo +! diagnostics +! Ek1=0.0d0 +! ii=0 +! do i=1,dimen +! do k=1,3 +! ii=ii+1 +! Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 +! enddo +! enddo +! write (iout,*) "Ek from eigenvectors",Ek1 +! end diagnostics +! Transform velocities to UNRES coordinate space + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + d_t_work(ind)=0.0d0 + do j=1,dimen + d_t_work(ind)=d_t_work(ind) & + +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) + enddo +! write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) +! call flush(iout) + enddo + enddo +! Transfer to the d_t vector + do j=1,3 + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + d_t(j,i)=d_t_work(ind) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + ind=ind+1 + d_t(j,i+nres)=d_t_work(ind) + enddo + endif + enddo +! call kinetic(EK) +! write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature",& +! 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 +! call flush(iout) + return + end subroutine random_vel +!----------------------------------------------------------------------------- +#ifndef LANG0 + subroutine sd_verlet_p_setup +! Sets up the parameters of stochastic Verlet algorithm +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use control, only: tcpu + use control_data +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8),dimension(6*nres) :: emgdt !(MAXRES6) maxres6=6*maxres + real(kind=8) :: pterm,vterm,rho,rhoc,vsig + real(kind=8),dimension(6*nres) :: pfric_vec,vfric_vec,afric_vec,& + prand_vec,vrand_vec1,vrand_vec2 !(MAXRES6) maxres6=6*maxres + logical :: lprn = .false. + real(kind=8) :: zero = 1.0d-8, gdt_radius = 0.05d0 + real(kind=8) :: ktm,gdt,egdt,gdt2,gdt3,gdt4,gdt5,gdt6,gdt7,gdt8,& + gdt9,psig,tt0 + integer :: i,maxres2 +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +! +! AL 8/17/04 Code adapted from tinker +! +! Get the frictional and random terms for stochastic dynamics in the +! eigenspace of mass-scaled UNRES friction matrix +! + maxres2=2*nres + do i = 1, dimen + gdt = fricgam(i) * d_time +! +! Stochastic dynamics reduces to simple MD for zero friction +! + if (gdt .le. zero) then + pfric_vec(i) = 1.0d0 + vfric_vec(i) = d_time + afric_vec(i) = 0.5d0 * d_time * d_time + prand_vec(i) = 0.0d0 + vrand_vec1(i) = 0.0d0 + vrand_vec2(i) = 0.0d0 +! +! Analytical expressions when friction coefficient is large +! + else + if (gdt .ge. gdt_radius) then + egdt = dexp(-gdt) + pfric_vec(i) = egdt + vfric_vec(i) = (1.0d0-egdt) / fricgam(i) + afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) + pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt + vterm = 1.0d0 - egdt**2 + rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) +! +! Use series expansions when friction coefficient is small +! + else + gdt2 = gdt * gdt + gdt3 = gdt * gdt2 + gdt4 = gdt2 * gdt2 + gdt5 = gdt2 * gdt3 + gdt6 = gdt3 * gdt3 + gdt7 = gdt3 * gdt4 + gdt8 = gdt4 * gdt4 + gdt9 = gdt4 * gdt5 + afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 & + - gdt5/120.0d0 + gdt6/720.0d0 & + - gdt7/5040.0d0 + gdt8/40320.0d0 & + - gdt9/362880.0d0) / fricgam(i)**2 + vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) + pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) + pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 & + + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 & + + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 & + + 127.0d0*gdt9/90720.0d0 + vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 & + - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 & + - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 & + - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 + rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 & + - 17.0d0*gdt2/1280.0d0 & + + 17.0d0*gdt3/6144.0d0 & + + 40967.0d0*gdt4/34406400.0d0 & + - 57203.0d0*gdt5/275251200.0d0 & + - 1429487.0d0*gdt6/13212057600.0d0) + end if +! +! Compute the scaling factors of random terms for the nonzero friction case +! + ktm = 0.5d0*d_time/fricgam(i) + psig = dsqrt(ktm*pterm) / fricgam(i) + vsig = dsqrt(ktm*vterm) + rhoc = dsqrt(1.0d0 - rho*rho) + prand_vec(i) = psig + vrand_vec1(i) = vsig * rho + vrand_vec2(i) = vsig * rhoc + end if + end do + if (lprn) then + write (iout,*) & + "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",& + " vrand_vec2" + do i=1,dimen + write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),& + afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) + enddo + endif +! +! Transform from the eigenspace of mass-scaled friction matrix to UNRES variables +! +#ifndef LANG0 + call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) + call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) + call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) + call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) +#endif +#ifdef MPI + t_sdsetup=t_sdsetup+MPI_Wtime() +#else + t_sdsetup=t_sdsetup+tcpu()-tt0 +#endif + return + end subroutine sd_verlet_p_setup +!----------------------------------------------------------------------------- + subroutine eigtransf1(n,ndim,ab,d,c) + +!el implicit none + integer :: n,ndim + real(kind=8) :: ab(ndim,ndim,n),c(ndim,n),d(ndim) + integer :: i,j,k + do i=1,n + do j=1,n + c(i,j)=0.0d0 + do k=1,n + c(i,j)=c(i,j)+ab(k,j,i)*d(k) + enddo + enddo + enddo + return + end subroutine eigtransf1 +!----------------------------------------------------------------------------- + subroutine eigtransf(n,ndim,a,b,d,c) + +!el implicit none + integer :: n,ndim + real(kind=8) :: a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) + integer :: i,j,k + do i=1,n + do j=1,n + c(i,j)=0.0d0 + do k=1,n + c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) + enddo + enddo + enddo + return + end subroutine eigtransf +!----------------------------------------------------------------------------- + subroutine sd_verlet1 + +! Applying stochastic velocity Verlet algorithm - step 1 to velocities + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec + logical :: lprn = .false. + real(kind=8) :: ddt1,ddt2 + integer :: i,j,ind,inres + +! write (iout,*) "dc_old" +! do i=0,nres +! write (iout,'(i5,3f10.5,5x,3f10.5)') +! & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) +! enddo + do j=1,3 + dc_work(j)=dc_old(j,0) + d_t_work(j)=d_t_old(j,0) + d_a_work(j)=d_a_old(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc_work(ind+j)=dc_old(j,i) + d_t_work(ind+j)=d_t_old(j,i) + d_a_work(ind+j)=d_a_old(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + dc_work(ind+j)=dc_old(j,i+nres) + d_t_work(ind+j)=d_t_old(j,i+nres) + d_a_work(ind+j)=d_a_old(j,i+nres) + enddo + ind=ind+3 + endif + enddo +#ifndef LANG0 + if (lprn) then + write (iout,*) & + "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",& + " vrand_mat2" + do i=1,dimen + do j=1,dimen + write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),& + vfric_mat(i,j),afric_mat(i,j),& + prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) + enddo + enddo + endif + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) & + +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) + ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) + ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) + enddo + d_t_work_new(i)=ddt1+0.5d0*ddt2 + d_t_work(i)=ddt1+ddt2 + enddo +#endif + do j=1,3 + dc(j,0)=dc_work(j) + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=dc_work(ind+j) + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + dc(j,inres)=dc_work(ind+j) + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end subroutine sd_verlet1 +!----------------------------------------------------------------------------- + subroutine sd_verlet2 + +! Calculating the adjusted velocities for accelerations + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +!el real(kind=8),dimension(6*nres) :: stochforcvec,stochforcvecV !(MAXRES6) maxres6=6*maxres + real(kind=8),dimension(6*nres) :: stochforcvecV !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec +! + real(kind=8) :: ddt1,ddt2 + integer :: i,j,ind,inres +! Compute the stochastic forces which contribute to velocity change +! + call stochastic_force(stochforcvecV) + +#ifndef LANG0 + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) + ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ & + vrand_mat2(i,j)*stochforcvecV(j) + enddo + d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 + enddo +#endif + do j=1,3 + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end subroutine sd_verlet2 +!----------------------------------------------------------------------------- + subroutine sd_verlet_ciccotti_setup + +! Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's +! version +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use control, only: tcpu + use control_data +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8),dimension(6*nres) :: emgdt !(MAXRES6) maxres6=6*maxres + real(kind=8) :: pterm,vterm,rho,rhoc,vsig + real(kind=8),dimension(6*nres) :: pfric_vec,vfric_vec,afric_vec,& + prand_vec,vrand_vec1,vrand_vec2 !(MAXRES6) maxres6=6*maxres + logical :: lprn = .false. + real(kind=8) :: zero = 1.0d-8, gdt_radius = 0.05d0 + real(kind=8) :: ktm,gdt,egdt,tt0 + integer :: i,maxres2 +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +! +! AL 8/17/04 Code adapted from tinker +! +! Get the frictional and random terms for stochastic dynamics in the +! eigenspace of mass-scaled UNRES friction matrix +! + maxres2=2*nres + do i = 1, dimen + write (iout,*) "i",i," fricgam",fricgam(i) + gdt = fricgam(i) * d_time +! +! Stochastic dynamics reduces to simple MD for zero friction +! + if (gdt .le. zero) then + pfric_vec(i) = 1.0d0 + vfric_vec(i) = d_time + afric_vec(i) = 0.5d0*d_time*d_time + prand_vec(i) = afric_vec(i) + vrand_vec2(i) = vfric_vec(i) +! +! Analytical expressions when friction coefficient is large +! + else + egdt = dexp(-gdt) + pfric_vec(i) = egdt + vfric_vec(i) = dexp(-0.5d0*gdt)*d_time + afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time + prand_vec(i) = afric_vec(i) + vrand_vec2(i) = vfric_vec(i) +! +! Compute the scaling factors of random terms for the nonzero friction case +! +! ktm = 0.5d0*d_time/fricgam(i) +! psig = dsqrt(ktm*pterm) / fricgam(i) +! vsig = dsqrt(ktm*vterm) +! prand_vec(i) = psig*afric_vec(i) +! vrand_vec2(i) = vsig*vfric_vec(i) + end if + end do + if (lprn) then + write (iout,*) & + "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",& + " vrand_vec2" + do i=1,dimen + write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),& + afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) + enddo + endif +! +! Transform from the eigenspace of mass-scaled friction matrix to UNRES variables +! + call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) + call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) + call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) +#ifdef MPI + t_sdsetup=t_sdsetup+MPI_Wtime() +#else + t_sdsetup=t_sdsetup+tcpu()-tt0 +#endif + return + end subroutine sd_verlet_ciccotti_setup +!----------------------------------------------------------------------------- + subroutine sd_verlet1_ciccotti + +! Applying stochastic velocity Verlet algorithm - step 1 to velocities +! implicit real*8 (a-h,o-z) + use energy_data +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec + logical :: lprn = .false. + real(kind=8) :: ddt1,ddt2 + integer :: i,j,ind,inres +! write (iout,*) "dc_old" +! do i=0,nres +! write (iout,'(i5,3f10.5,5x,3f10.5)') +! & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) +! enddo + do j=1,3 + dc_work(j)=dc_old(j,0) + d_t_work(j)=d_t_old(j,0) + d_a_work(j)=d_a_old(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc_work(ind+j)=dc_old(j,i) + d_t_work(ind+j)=d_t_old(j,i) + d_a_work(ind+j)=d_a_old(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + dc_work(ind+j)=dc_old(j,i+nres) + d_t_work(ind+j)=d_t_old(j,i+nres) + d_a_work(ind+j)=d_a_old(j,i+nres) + enddo + ind=ind+3 + endif + enddo + +#ifndef LANG0 + if (lprn) then + write (iout,*) & + "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",& + " vrand_mat2" + do i=1,dimen + do j=1,dimen + write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),& + vfric_mat(i,j),afric_mat(i,j),& + prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) + enddo + enddo + endif + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) & + +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) + ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) + ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) + enddo + d_t_work_new(i)=ddt1+0.5d0*ddt2 + d_t_work(i)=ddt1+ddt2 + enddo +#endif + do j=1,3 + dc(j,0)=dc_work(j) + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=dc_work(ind+j) + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + dc(j,inres)=dc_work(ind+j) + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end subroutine sd_verlet1_ciccotti +!----------------------------------------------------------------------------- + subroutine sd_verlet2_ciccotti + +! Calculating the adjusted velocities for accelerations + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +!el real(kind=8),dimension(6*nres) :: stochforcvec,stochforcvecV !(MAXRES6) maxres6=6*maxres + real(kind=8),dimension(6*nres) :: stochforcvecV !(MAXRES6) maxres6=6*maxres +!el common /stochcalc/ stochforcvec + real(kind=8) :: ddt1,ddt2 + integer :: i,j,ind,inres +! +! Compute the stochastic forces which contribute to velocity change +! + call stochastic_force(stochforcvecV) +#ifndef LANG0 + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + + ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) +! ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) + ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) + enddo + d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 + enddo +#endif + do j=1,3 + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end subroutine sd_verlet2_ciccotti +#endif +!----------------------------------------------------------------------------- +! moments.f +!----------------------------------------------------------------------------- + subroutine inertia_tensor + +! Calculating the intertia tensor for the entire protein in order to +! remove the perpendicular components of velocity matrix which cause +! the molecule to rotate. + use comm_gucio + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + + real(kind=8),dimension(3,3) :: Im,Imcp,eigvec,Id + real(kind=8),dimension(3) :: pr,eigval,L,vp,vrot + real(kind=8) :: M_SC,mag,mag2 + real(kind=8),dimension(3,0:nres) :: vpp !(3,0:MAXRES) + real(kind=8),dimension(3) :: vs_p,pp,incr,v + real(kind=8),dimension(3,3) :: pr1,pr2 + +!el common /gucio/ cm + integer :: iti,inres,i,j,k + do i=1,3 + do j=1,3 + Im(i,j)=0.0d0 + pr1(i,j)=0.0d0 + pr2(i,j)=0.0d0 + enddo + L(i)=0.0d0 + cm(i)=0.0d0 + vrot(i)=0.0d0 + enddo +! calculating the center of the mass of the protein + do i=nnt,nct-1 + do j=1,3 + cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) + enddo + enddo + do j=1,3 + cm(j)=mp*cm(j) + enddo + M_SC=0.0d0 + do i=nnt,nct + iti=iabs(itype(i)) + M_SC=M_SC+msc(iabs(iti)) + inres=i+nres + do j=1,3 + cm(j)=cm(j)+msc(iabs(iti))*c(j,inres) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) + enddo + + do i=nnt,nct-1 + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) + Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) + Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) + Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct + iti=iabs(itype(i)) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + Im(1,1)=Im(1,1)+msc(iabs(iti))*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-msc(iabs(iti))*pr(1)*pr(2) + Im(1,3)=Im(1,3)-msc(iabs(iti))*pr(1)*pr(3) + Im(2,3)=Im(2,3)-msc(iabs(iti))*pr(2)*pr(3) + Im(2,2)=Im(2,2)+msc(iabs(iti))*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+msc(iabs(iti))*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct-1 + Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* & + vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* & + vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* & + vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* & + vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* & + vbld(i+1)*vbld(i+1)*0.25d0 + Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* & + vbld(i+1)*vbld(i+1)*0.25d0 + enddo + + + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + iti=iabs(itype(i)) + inres=i+nres + Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* & + dc_norm(1,inres))*vbld(inres)*vbld(inres) + Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* & + dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* & + dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* & + dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* & + dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* & + dc_norm(3,inres))*vbld(inres)*vbld(inres) + endif + enddo + + call angmom(cm,L) +! write(iout,*) "The angular momentum before adjustment:" +! write(iout,*) (L(j),j=1,3) + + Im(2,1)=Im(1,2) + Im(3,1)=Im(1,3) + Im(3,2)=Im(2,3) + +! Copying the Im matrix for the djacob subroutine + do i=1,3 + do j=1,3 + Imcp(i,j)=Im(i,j) + Id(i,j)=0.0d0 + enddo + enddo + +! Finding the eigenvectors and eignvalues of the inertia tensor + call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) +! write (iout,*) "Eigenvalues & Eigenvectors" +! write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) +! write (iout,*) +! do i=1,3 +! write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) +! enddo +! Constructing the diagonalized matrix + do i=1,3 + if (dabs(eigval(i)).gt.1.0d-15) then + Id(i,i)=1.0d0/eigval(i) + else + Id(i,i)=0.0d0 + endif + enddo + do i=1,3 + do j=1,3 + Imcp(i,j)=eigvec(j,i) + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) + enddo + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) + enddo + enddo + enddo +! Calculating the total rotational velocity of the molecule + do i=1,3 + do j=1,3 + vrot(i)=vrot(i)+pr2(i,j)*L(j) + enddo + enddo +! Resetting the velocities + do i=nnt,nct-1 + call vecpr(vrot(1),dc(1,i),vp) + do j=1,3 + d_t(j,i)=d_t(j,i)-vp(j) + enddo + enddo + do i=nnt,nct + if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + call vecpr(vrot(1),dc(1,inres),vp) + do j=1,3 + d_t(j,inres)=d_t(j,inres)-vp(j) + enddo + endif + enddo + call angmom(cm,L) +! write(iout,*) "The angular momentum after adjustment:" +! write(iout,*) (L(j),j=1,3) + + return + end subroutine inertia_tensor +!----------------------------------------------------------------------------- + subroutine angmom(cm,L) + + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + + real(kind=8),dimension(3) :: L,cm,pr,vp,vrot,incr,v,pp + integer :: iti,inres,i,j +! Calculate the angular momentum + do j=1,3 + L(j)=0.0d0 + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + call vecpr(pr(1),v(1),vp) + do j=1,3 + L(j)=L(j)+mp*vp(j) + enddo + do j=1,3 + pr(j)=0.5d0*dc(j,i) + pp(j)=0.5d0*d_t(j,i) + enddo + call vecpr(pr(1),pp(1),vp) + do j=1,3 + L(j)=L(j)+Ip*vp(j) + enddo + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + else + do j=1,3 + v(j)=incr(j) + enddo + endif + call vecpr(pr(1),v(1),vp) +! write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), +! & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) + do j=1,3 + L(j)=L(j)+msc(iabs(iti))*vp(j) + enddo +! write (iout,*) "L",(l(j),j=1,3) + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + call vecpr(dc(1,inres),d_t(1,inres),vp) + do j=1,3 + L(j)=L(j)+Isc(iti)*vp(j) + enddo + endif + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo + return + end subroutine angmom +!----------------------------------------------------------------------------- + subroutine vcm_vel(vcm) + + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' + real(kind=8),dimension(3) :: vcm,vv + real(kind=8) :: summas,amas + integer :: i,j + + do j=1,3 + vcm(j)=0.0d0 + vv(j)=d_t(j,0) + enddo + summas=0.0d0 + do i=nnt,nct + if (i.lt.nct) then + summas=summas+mp + do j=1,3 + vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) + enddo + endif + amas=msc(iabs(itype(i))) + summas=summas+amas + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) + enddo + else + do j=1,3 + vcm(j)=vcm(j)+amas*vv(j) + enddo + endif + do j=1,3 + vv(j)=vv(j)+d_t(j,i) + enddo + enddo +! write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas + do j=1,3 + vcm(j)=vcm(j)/summas + enddo + return + end subroutine vcm_vel +!----------------------------------------------------------------------------- +! rattle.F +!----------------------------------------------------------------------------- + subroutine rattle1 +! RATTLE algorithm for velocity Verlet - step 1, UNRES +! AL 9/24/04 + use comm_przech + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef RATTLE +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +!el real(kind=8) :: gginv(2*nres,2*nres),& +!el gdc(3,2*nres,2*nres) + real(kind=8) :: dC_uncor(3,2*nres) !,& +!el real(kind=8) :: Cmat(2*nres,2*nres) + real(kind=8) :: x(2*nres),xcorr(3,2*nres) !maxres2=2*maxres +!el common /przechowalnia/ GGinv,gdc,Cmat,nbond +!el common /przechowalnia/ nbond + integer :: max_rattle = 5 + logical :: lprn = .false., lprn1 = .false., not_done + real(kind=8) :: tol_rattle = 1.0d-5 + + integer :: ii,i,j,jj,l,ind,ind1,nres2 + nres2=2*nres + +!el /common/ przechowalnia + + if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2)) + if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2)) + if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2)) +!el-------- + if (lprn) write (iout,*) "RATTLE1" + nbond=nct-nnt + do i=nnt,nct + if (itype(i).ne.10) nbond=nbond+1 + enddo +! Make a folded form of the Ginv-matrix + ind=0 + ii=0 + do i=nnt,nct-1 + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + endif + enddo + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + endif + enddo + enddo + endif + enddo + if (lprn1) then + write (iout,*) "Matrix GGinv" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) + endif + not_done=.true. + iter=0 + do while (not_done) + iter=iter+1 + if (iter.gt.max_rattle) then + write (iout,*) "Error - too many iterations in RATTLE." + stop + endif +! Calculate the matrix C = GG**(-1) dC_old o dC + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i+nres) + enddo + endif + enddo + do i=1,nbond + ind=0 + do k=nnt,nct-1 + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) + enddo + endif + enddo + enddo +! Calculate deviations from standard virtual-bond lengths + ind=0 + do i=nnt,nct-1 + ind=ind+1 + x(ind)=vbld(i+1)**2-vbl**2 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + endif + enddo + if (lprn) then + write (iout,*) "Coordinates and violations" + do i=1,nbond + write(iout,'(i5,3f10.5,5x,e15.5)') & + i,(dC_uncor(j,i),j=1,3),x(i) + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i+nres,ind,(d_t_new(j,i+nres),j=1,3),& + scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) + endif + enddo +! write (iout,*) "gdc" +! do i=1,nbond +! write (iout,*) "i",i +! do j=1,nbond +! write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) +! enddo +! enddo + endif + xmax=dabs(x(1)) + do i=2,nbond + if (dabs(x(i)).gt.xmax) then + xmax=dabs(x(i)) + endif + enddo + if (xmax.lt.tol_rattle) then + not_done=.false. + goto 100 + endif +! Calculate the matrix of the system of equations + do i=1,nbond + do j=1,nbond + Cmat(i,j)=0.0d0 + do k=1,3 + Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) + endif + call gauss(Cmat,X,MAXRES2,nbond,1,*10) +! Add constraint term to positions + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=0.5d0*xx + dC(j,i)=dC(j,i)-xx + d_t_new(j,i)=d_t_new(j,i)-xx/d_time + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=0.5d0*xx + dC(j,i+nres)=dC(j,i+nres)-xx + d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time + enddo + endif + enddo +! Rebuild the chain using the new coordinates + call chainbuild_cart + if (lprn) then + write (iout,*) "New coordinates, Lagrange multipliers,",& + " and differences between actual and standard bond lengths" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + xx=vbld(i+1)**2-vbl**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i),j=1,3),x(ind),xx + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i+nres),j=1,3),x(ind),xx + endif + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i+nres,ind,(d_t_new(j,i+nres),j=1,3),& + scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) + endif + enddo + endif + enddo + 100 continue + return + 10 write (iout,*) "Error - singularity in solving the system",& + " of equations for Lagrange multipliers." + stop +#else + write (iout,*) & + "RATTLE inactive; use -DRATTLE switch at compile time." + stop +#endif + end subroutine rattle1 +!----------------------------------------------------------------------------- + subroutine rattle2 +! RATTLE algorithm for velocity Verlet - step 2, UNRES +! AL 9/24/04 + use comm_przech + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef RATTLE +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +!el real(kind=8) :: gginv(2*nres,2*nres),& +!el gdc(3,2*nres,2*nres) + real(kind=8) :: dC_uncor(3,2*nres) !,& +!el Cmat(2*nres,2*nres) + real(kind=8) :: x(2*nres) !maxres2=2*maxres +!el common /przechowalnia/ GGinv,gdc,Cmat,nbond +!el common /przechowalnia/ nbond + integer :: max_rattle = 5 + logical :: lprn = .false., lprn1 = .false., not_done + real(kind=8) :: tol_rattle = 1.0d-5 + integer :: nres2 + nres2=2*nres + +!el /common/ przechowalnia + if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2)) + if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2)) + if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2)) +!el-------- + if (lprn) write (iout,*) "RATTLE2" + if (lprn) write (iout,*) "Velocity correction" +! Calculate the matrix G dC + do i=1,nbond + ind=0 + do k=nnt,nct-1 + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC(j,k) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres) + enddo + endif + enddo + enddo +! if (lprn) then +! write (iout,*) "gdc" +! do i=1,nbond +! write (iout,*) "i",i +! do j=1,nbond +! write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) +! enddo +! enddo +! endif +! Calculate the matrix of the system of equations + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,nbond + Cmat(ind,j)=0.0d0 + do k=1,3 + Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j) + enddo + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,nbond + Cmat(ind,j)=0.0d0 + do k=1,3 + Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j) + enddo + enddo + endif + enddo +! Calculate the scalar product dC o d_t_new + ind=0 + do i=nnt,nct-1 + ind=ind+1 + x(ind)=scalar(d_t(1,i),dC(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres)) + endif + enddo + if (lprn) then + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i,ind,(d_t(j,i),j=1,3),x(ind) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind) + endif + enddo + endif + xmax=dabs(x(1)) + do i=2,nbond + if (dabs(x(i)).gt.xmax) then + xmax=dabs(x(i)) + endif + enddo + if (xmax.lt.tol_rattle) then + not_done=.false. + goto 100 + endif + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) + endif + call gauss(Cmat,X,MAXRES2,nbond,1,*10) +! Add constraint term to velocities + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + d_t(j,i)=d_t(j,i)-xx + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + d_t(j,i+nres)=d_t(j,i+nres)-xx + enddo + endif + enddo + if (lprn) then + write (iout,*) & + "New velocities, Lagrange multipliers violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)') & + i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,2e15.5)') & + i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind),& + scalar(d_t(1,i+nres),dC(1,i+nres)) + endif + enddo + endif + 100 continue + return + 10 write (iout,*) "Error - singularity in solving the system",& + " of equations for Lagrange multipliers." + stop +#else + write (iout,*) & + "RATTLE inactive; use -DRATTLE option at compile time." + stop +#endif + end subroutine rattle2 +!----------------------------------------------------------------------------- + subroutine rattle_brown +! RATTLE/LINCS algorithm for Brownian dynamics, UNRES +! AL 9/24/04 + use comm_przech + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef RATTLE +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +!el real(kind=8) :: gginv(2*nres,2*nres),& +!el gdc(3,2*nres,2*nres) + real(kind=8) :: dC_uncor(3,2*nres) !,& +!el real(kind=8) :: Cmat(2*nres,2*nres) + real(kind=8) :: x(2*nres) !maxres2=2*maxres +!el common /przechowalnia/ GGinv,gdc,Cmat,nbond +!el common /przechowalnia/ nbond + integer :: max_rattle = 5 + logical :: lprn = .true., lprn1 = .true., not_done + real(kind=8) :: tol_rattle = 1.0d-5 + integer :: nres2 + nres2=2*nres + +!el /common/ przechowalnia + if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2)) + if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2)) + if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2)) +!el-------- + + if (lprn) write (iout,*) "RATTLE_BROWN" + nbond=nct-nnt + do i=nnt,nct + if (itype(i).ne.10) nbond=nbond+1 + enddo +! Make a folded form of the Ginv-matrix + ind=0 + ii=0 + do i=nnt,nct-1 + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) + enddo + endif + enddo + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1) + enddo + endif + enddo + enddo + endif + enddo + if (lprn1) then + write (iout,*) "Matrix GGinv" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) + endif + not_done=.true. + iter=0 + do while (not_done) + iter=iter+1 + if (iter.gt.max_rattle) then + write (iout,*) "Error - too many iterations in RATTLE." + stop + endif +! Calculate the matrix C = GG**(-1) dC_old o dC + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i+nres) + enddo + endif + enddo + do i=1,nbond + ind=0 + do k=nnt,nct-1 + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) + enddo + endif + enddo + enddo +! Calculate deviations from standard virtual-bond lengths + ind=0 + do i=nnt,nct-1 + ind=ind+1 + x(ind)=vbld(i+1)**2-vbl**2 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + endif + enddo + if (lprn) then + write (iout,*) "Coordinates and violations" + do i=1,nbond + write(iout,'(i5,3f10.5,5x,e15.5)') & + i,(dC_uncor(j,i),j=1,3),x(i) + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i+nres,ind,(d_t(j,i+nres),j=1,3),& + scalar(d_t(1,i+nres),dC_old(1,i+nres)) + endif + enddo + write (iout,*) "gdc" + do i=1,nbond + write (iout,*) "i",i + do j=1,nbond + write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) + enddo + enddo + endif + xmax=dabs(x(1)) + do i=2,nbond + if (dabs(x(i)).gt.xmax) then + xmax=dabs(x(i)) + endif + enddo + if (xmax.lt.tol_rattle) then + not_done=.false. + goto 100 + endif +! Calculate the matrix of the system of equations + do i=1,nbond + do j=1,nbond + Cmat(i,j)=0.0d0 + do k=1,3 + Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) + endif + call gauss(Cmat,X,MAXRES2,nbond,1,*10) +! Add constraint term to positions + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=-0.5d0*xx + d_t(j,i)=d_t(j,i)+xx/d_time + dC(j,i)=dC(j,i)+xx + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=-0.5d0*xx + d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time + dC(j,i+nres)=dC(j,i+nres)+xx + enddo + endif + enddo +! Rebuild the chain using the new coordinates + call chainbuild_cart + if (lprn) then + write (iout,*) "New coordinates, Lagrange multipliers,",& + " and differences between actual and standard bond lengths" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + xx=vbld(i+1)**2-vbl**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i),j=1,3),x(ind),xx + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & + i,(dC(j,i+nres),j=1,3),x(ind),xx + endif + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') & + i+nres,ind,(d_t_new(j,i+nres),j=1,3),& + scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) + endif + enddo + endif + enddo + 100 continue + return + 10 write (iout,*) "Error - singularity in solving the system",& + " of equations for Lagrange multipliers." + stop +#else + write (iout,*) & + "RATTLE inactive; use -DRATTLE option at compile time" + stop +#endif + end subroutine rattle_brown +!----------------------------------------------------------------------------- +! stochfric.F +!----------------------------------------------------------------------------- + subroutine friction_force + + use energy_data + use REMD_data + use comm_syfek +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.IOUNITS' +!el real(kind=8),dimension(6*nres) :: gamvec !(MAXRES6) maxres6=6*maxres +!el common /syfek/ gamvec + real(kind=8) :: vv(3),vvtot(3,nres),v_work(6*nres) !,& +!el ginvfric(2*nres,2*nres) !maxres2=2*maxres +!el common /przechowalnia/ ginvfric + + logical :: lprn = .false., checkmode = .false. + integer :: i,j,ind,k,nres2,nres6 + nres2=2*nres + nres6=6*nres + + if(.not.allocated(gamvec)) allocate(gamvec(nres6)) !(MAXRES6) + if(.not.allocated(ginvfric)) allocate(ginvfric(nres2,nres2)) !maxres2=2*maxres + do i=0,nres2 + do j=1,3 + friction(j,i)=0.0d0 + enddo + enddo + + do j=1,3 + d_t_work(j)=d_t(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t_work(ind+j)=d_t(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + do j=1,3 + d_t_work(ind+j)=d_t(j,i+nres) + enddo + ind=ind+3 + endif + enddo + + call fricmat_mult(d_t_work,fric_work) + + if (.not.checkmode) return + + if (lprn) then + write (iout,*) "d_t_work and fric_work" + do i=1,3*dimen + write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i) + enddo + endif + do j=1,3 + friction(j,0)=fric_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + friction(j,i)=fric_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + do j=1,3 + friction(j,i+nres)=fric_work(ind+j) + enddo + ind=ind+3 + endif + enddo + if (lprn) then + write(iout,*) "Friction backbone" + do i=0,nct-1 + write(iout,'(i5,3e15.5,5x,3e15.5)') & + i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3) + enddo + write(iout,*) "Friction side chain" + do i=nnt,nct + write(iout,'(i5,3e15.5,5x,3e15.5)') & + i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3) + enddo + endif + if (lprn) then + do j=1,3 + vv(j)=d_t(j,0) + enddo + do i=nnt,nct + do j=1,3 + vvtot(j,i)=vv(j)+0.5d0*d_t(j,i) + vvtot(j,i+nres)=vv(j)+d_t(j,i+nres) + vv(j)=vv(j)+d_t(j,i) + enddo + enddo + write (iout,*) "vvtot backbone and sidechain" + do i=nnt,nct + write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3),& + (vvtot(j,i+nres),j=1,3) + enddo + ind=0 + do i=nnt,nct-1 + do j=1,3 + v_work(ind+j)=vvtot(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + do j=1,3 + v_work(ind+j)=vvtot(j,i+nres) + enddo + ind=ind+3 + enddo + write (iout,*) "v_work gamvec and site-based friction forces" + do i=1,dimen1 + write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i),& + gamvec(i)*v_work(i) + enddo +! do i=1,dimen +! fric_work1(i)=0.0d0 +! do j=1,dimen1 +! fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j) +! enddo +! enddo +! write (iout,*) "fric_work and fric_work1" +! do i=1,dimen +! write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i) +! enddo + do i=1,dimen + do j=1,dimen + ginvfric(i,j)=0.0d0 + do k=1,dimen + ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j) + enddo + enddo + enddo + write (iout,*) "ginvfric" + do i=1,dimen + write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen) + enddo + write (iout,*) "symmetry check" + do i=1,dimen + do j=1,i-1 + write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i) + enddo + enddo + endif + return + end subroutine friction_force +!----------------------------------------------------------------------------- + subroutine setup_fricmat + +! use MPI + use energy_data + use control_data, only:time_Bcast + use control, only:tcpu + use comm_syfek +! implicit real*8 (a-h,o-z) +#ifdef MPI + use MPI_data + include 'mpif.h' + real(kind=8) :: time00 +#endif +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +! include 'COMMON.SETUP' +! include 'COMMON.TIME1' +! integer licznik /0/ +! save licznik +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.IOUNITS' + integer :: IERROR + integer :: i,j,ind,ind1,m + logical :: lprn = .false. + real(kind=8) :: dtdi !el ,gamvec(2*nres) +!el real(kind=8),dimension(2*nres,2*nres) :: ginvfric,fcopy + real(kind=8),dimension(2*nres,2*nres) :: fcopy +!el real(kind=8),dimension(2*nres*(2*nres+1)/2) :: Ghalf !(mmaxres2) (mmaxres2=(maxres2*(maxres2+1)/2)) +!el common /syfek/ gamvec + real(kind=8) :: work(8*2*nres) + integer :: iwork(2*nres) +!el common /przechowalnia/ ginvfric,Ghalf,fcopy + integer :: ii,iti,k,l,nzero,nres2,nres6,ierr +#ifdef MPI + if (fg_rank.ne.king) goto 10 +#endif + nres2=2*nres + nres6=6*nres + + if(.not.allocated(gamvec)) allocate(gamvec(nres2)) !(MAXRES2) + if(.not.allocated(ginvfric)) allocate(ginvfric(nres2,nres2)) !maxres2=2*maxres +!el if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2)) !maxres2=2*maxres +!el allocate(fcopy(nres2,nres2)) !maxres2=2*maxres + if(.not.allocated(Ghalf)) allocate(Ghalf(nres2*(nres2+1)/2)) !maxres2=2*maxres + +!el if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) +! Zeroing out fricmat + do i=1,dimen + do j=1,dimen + fricmat(i,j)=0.0d0 + enddo + enddo +! Load the friction coefficients corresponding to peptide groups + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + gamvec(ind1)=gamp + enddo +! Load the friction coefficients corresponding to side chains + m=nct-nnt + ind=0 + gamsc(ntyp1)=1.0d0 + do i=nnt,nct + ind=ind+1 + ii = ind+m + iti=itype(i) + gamvec(ii)=gamsc(iabs(iti)) + enddo + if (surfarea) call sdarea(gamvec) +! if (lprn) then +! write (iout,*) "Matrix A and vector gamma" +! do i=1,dimen1 +! write (iout,'(i2,$)') i +! do j=1,dimen +! write (iout,'(f4.1,$)') A(i,j) +! enddo +! write (iout,'(f8.3)') gamvec(i) +! enddo +! endif + if (lprn) then + write (iout,*) "Vector gamvec" + do i=1,dimen1 + write (iout,'(i5,f10.5)') i, gamvec(i) + enddo + endif + +! The friction matrix + do k=1,dimen + do i=1,dimen + dtdi=0.0d0 + do j=1,dimen1 + dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j) + enddo + fricmat(k,i)=dtdi + enddo + enddo + + if (lprn) then + write (iout,'(//a)') "Matrix fricmat" + call matout2(dimen,dimen,nres2,nres2,fricmat) + endif + if (lang.eq.2 .or. lang.eq.3) then +! Mass-scale the friction matrix if non-direct integration will be performed + do i=1,dimen + do j=1,dimen + Ginvfric(i,j)=0.0d0 + do k=1,dimen + do l=1,dimen + Ginvfric(i,j)=Ginvfric(i,j)+ & + Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l) + enddo + enddo + enddo + enddo +! Diagonalize the friction matrix + ind=0 + do i=1,dimen + do j=1,i + ind=ind+1 + Ghalf(ind)=Ginvfric(i,j) + enddo + enddo + call gldiag(nres2,dimen,dimen,Ghalf,work,fricgam,fricvec,& + ierr,iwork) + if (lprn) then + write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",& + " mass-scaled friction matrix" + call eigout(dimen,dimen,nres2,nres2,fricvec,fricgam) + endif +! Precompute matrices for tinker stochastic integrator +#ifndef LANG0 + do i=1,dimen + do j=1,dimen + mt1(i,j)=0.0d0 + mt2(i,j)=0.0d0 + do k=1,dimen + mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j) + mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j) + enddo + mt3(j,i)=mt1(i,j) + enddo + enddo +#endif + else if (lang.eq.4) then +! Diagonalize the friction matrix + ind=0 + do i=1,dimen + do j=1,i + ind=ind+1 + Ghalf(ind)=fricmat(i,j) + enddo + enddo + call gldiag(nres2,dimen,dimen,Ghalf,work,fricgam,fricvec,& + ierr,iwork) + if (lprn) then + write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",& + " friction matrix" + call eigout(dimen,dimen,nres2,nres2,fricvec,fricgam) + endif +! Determine the number of zero eigenvalues of the friction matrix + nzero=max0(dimen-dimen1,0) +! do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen) +! nzero=nzero+1 +! enddo + write (iout,*) "Number of zero eigenvalues:",nzero + do i=1,dimen + do j=1,dimen + fricmat(i,j)=0.0d0 + do k=nzero+1,dimen + fricmat(i,j)=fricmat(i,j) & + +fricvec(i,k)*fricvec(j,k)/fricgam(k) + enddo + enddo + enddo + if (lprn) then + write (iout,'(//a)') "Generalized inverse of fricmat" + call matout(dimen,dimen,nres6,nres6,fricmat) + endif + endif +#ifdef MPI + 10 continue + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then +! The matching BROADCAST for fg processors is called in ERGASTULUM +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif + call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR) +#ifdef MPI + time_Bcast=time_Bcast+MPI_Wtime()-time00 +#else + time_Bcast=time_Bcast+tcpu()-time00 +#endif +! print *,"Processor",myrank, +! & " BROADCAST iorder in SETUP_FRICMAT" + endif +! licznik=licznik+1 + write (iout,*) "setup_fricmat licznik"!,licznik !sp +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +! Scatter the friction matrix + call MPI_Scatterv(fricmat(1,1),nginv_counts(0),& + nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1),& + myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) +#ifdef TIMING +#ifdef MPI + time_scatter=time_scatter+MPI_Wtime()-time00 + time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00 +#else + time_scatter=time_scatter+tcpu()-time00 + time_scatter_fmat=time_scatter_fmat+tcpu()-time00 +#endif +#endif + do i=1,dimen + do j=1,2*my_ng_count + fricmat(j,i)=fcopy(i,j) + enddo + enddo +! write (iout,*) "My chunk of fricmat" +! call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) + endif +#endif + return + end subroutine setup_fricmat +!----------------------------------------------------------------------------- + subroutine stochastic_force(stochforcvec) + + use energy_data + use random, only:anorm_distr +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use control, only: tcpu + use control_data +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +! include 'COMMON.TIME1' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.IOUNITS' + + real(kind=8) :: x,sig,lowb,highb + real(kind=8) :: ff(3),force(3,0:2*nres),zeta2,lowb2 + real(kind=8) :: highb2,sig2,forcvec(6*nres),stochforcvec(6*nres) + real(kind=8) :: time00 + logical :: lprn = .false. + integer :: i,j,ind + + do i=0,2*nres + do j=1,3 + stochforc(j,i)=0.0d0 + enddo + enddo + x=0.0d0 + +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +! Compute the stochastic forces acting on bodies. Store in force. + do i=nnt,nct-1 + sig=stdforcp(i) + lowb=-5*sig + highb=5*sig + do j=1,3 + force(j,i)=anorm_distr(x,sig,lowb,highb) + enddo + enddo + do i=nnt,nct + sig2=stdforcsc(i) + lowb2=-5*sig2 + highb2=5*sig2 + do j=1,3 + force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) + enddo + enddo +#ifdef MPI + time_fsample=time_fsample+MPI_Wtime()-time00 +#else + time_fsample=time_fsample+tcpu()-time00 +#endif +! Compute the stochastic forces acting on virtual-bond vectors. + do j=1,3 + ff(j)=0.0d0 + enddo + do i=nct-1,nnt,-1 + do j=1,3 + stochforc(j,i)=ff(j)+0.5d0*force(j,i) + enddo + do j=1,3 + ff(j)=ff(j)+force(j,i) + enddo + if (itype(i+1).ne.ntyp1) then + do j=1,3 + stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1) + ff(j)=ff(j)+force(j,i+nres+1) + enddo + endif + enddo + do j=1,3 + stochforc(j,0)=ff(j)+force(j,nnt+nres) + enddo + do i=nnt,nct + if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + do j=1,3 + stochforc(j,i+nres)=force(j,i+nres) + enddo + endif + enddo + + do j=1,3 + stochforcvec(j)=stochforc(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + stochforcvec(ind+j)=stochforc(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + do j=1,3 + stochforcvec(ind+j)=stochforc(j,i+nres) + enddo + ind=ind+3 + endif + enddo + if (lprn) then + write (iout,*) "stochforcvec" + do i=1,3*dimen + write(iout,'(i5,e15.5)') i,stochforcvec(i) + enddo + write(iout,*) "Stochastic forces backbone" + do i=0,nct-1 + write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3) + enddo + write(iout,*) "Stochastic forces side chain" + do i=nnt,nct + write(iout,'(i5,3e15.5)') & + i,(stochforc(j,i+nres),j=1,3) + enddo + endif + + if (lprn) then + + ind=0 + do i=nnt,nct-1 + write (iout,*) i,ind + do j=1,3 + forcvec(ind+j)=force(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + write (iout,*) i,ind + do j=1,3 + forcvec(j+ind)=force(j,i+nres) + enddo + ind=ind+3 + enddo + + write (iout,*) "forcvec" + ind=0 + do i=nnt,nct-1 + do j=1,3 + write (iout,'(2i3,2f10.5)') i,j,force(j,i),& + forcvec(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + do j=1,3 + write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres),& + forcvec(ind+j) + enddo + ind=ind+3 + enddo + + endif + + return + end subroutine stochastic_force +!----------------------------------------------------------------------------- + subroutine sdarea(gamvec) +! +! Scale the friction coefficients according to solvent accessible surface areas +! Code adapted from TINKER +! AL 9/3/04 +! + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + real(kind=8),dimension(2*nres) :: radius,gamvec !(maxres2) + real(kind=8),parameter :: twosix = 1.122462048309372981d0 + logical :: lprn = .false. + real(kind=8) :: probe,area,ratio + integer :: i,j,ind,iti +! +! determine new friction coefficients every few SD steps +! +! set the atomic radii to estimates of sigma values +! +! print *,"Entered sdarea" + probe = 0.0d0 + + do i=1,2*nres + radius(i)=0.0d0 + enddo +! Load peptide group radii + do i=nnt,nct-1 + radius(i)=pstok + enddo +! Load side chain radii + do i=nnt,nct + iti=itype(i) + radius(i+nres)=restok(iti) + enddo +! do i=1,2*nres +! write (iout,*) "i",i," radius",radius(i) +! enddo + do i = 1, 2*nres + radius(i) = radius(i) / twosix + if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe + end do +! +! scale atomic friction coefficients by accessible area +! + if (lprn) write (iout,*) & + "Original gammas, surface areas, scaling factors, new gammas, ",& + "std's of stochastic forces" + ind=0 + do i=nnt,nct-1 + if (radius(i).gt.0.0d0) then + call surfatom (i,area,radius) + ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1) + if (lprn) write (iout,'(i5,3f10.5,$)') & + i,gamvec(ind+1),area,ratio + do j=1,3 + ind=ind+1 + gamvec(ind) = ratio * gamvec(ind) + enddo + stdforcp(i)=stdfp*dsqrt(gamvec(ind)) + if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i) + endif + enddo + do i=nnt,nct + if (radius(i+nres).gt.0.0d0) then + call surfatom (i+nres,area,radius) + ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1) + if (lprn) write (iout,'(i5,3f10.5,$)') & + i,gamvec(ind+1),area,ratio + do j=1,3 + ind=ind+1 + gamvec(ind) = ratio * gamvec(ind) + enddo + stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind)) + if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i) + endif + enddo + + return + end subroutine sdarea +!----------------------------------------------------------------------------- +! surfatom.f +!----------------------------------------------------------------------------- +! +! +! ################################################### +! ## COPYRIGHT (C) 1996 by Jay William Ponder ## +! ## All Rights Reserved ## +! ################################################### +! +! ################################################################ +! ## ## +! ## subroutine surfatom -- exposed surface area of an atom ## +! ## ## +! ################################################################ +! +! +! "surfatom" performs an analytical computation of the surface +! area of a specified atom; a simplified version of "surface" +! +! literature references: +! +! T. J. Richmond, "Solvent Accessible Surface Area and +! Excluded Volume in Proteins", Journal of Molecular Biology, +! 178, 63-89 (1984) +! +! L. Wesson and D. Eisenberg, "Atomic Solvation Parameters +! Applied to Molecular Dynamics of Proteins in Solution", +! Protein Science, 1, 227-235 (1992) +! +! variables and parameters: +! +! ir number of atom for which area is desired +! area accessible surface area of the atom +! radius radii of each of the individual atoms +! +! + subroutine surfatom(ir,area,radius) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'sizes.i' +! include 'COMMON.GEO' +! include 'COMMON.IOUNITS' +! integer :: nres, + integer :: nsup,nstart_sup +! double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm +! common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), +! & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), +! & dc_work(MAXRES6),nres,nres0 + integer,parameter :: maxarc=300 + integer :: i,j,k,m + integer :: ii,ib,jb + integer :: io,ir + integer :: mi,ni,narc + integer :: key(maxarc) + integer :: intag(maxarc) + integer :: intag1(maxarc) + real(kind=8) :: area,arcsum + real(kind=8) :: arclen,exang + real(kind=8) :: delta,delta2 + real(kind=8) :: eps,rmove + real(kind=8) :: xr,yr,zr + real(kind=8) :: rr,rrsq + real(kind=8) :: rplus,rminus + real(kind=8) :: axx,axy,axz + real(kind=8) :: ayx,ayy + real(kind=8) :: azx,azy,azz + real(kind=8) :: uxj,uyj,uzj + real(kind=8) :: tx,ty,tz + real(kind=8) :: txb,tyb,td + real(kind=8) :: tr2,tr,txr,tyr + real(kind=8) :: tk1,tk2 + real(kind=8) :: thec,the,t,tb + real(kind=8) :: txk,tyk,tzk + real(kind=8) :: t1,ti,tf,tt + real(kind=8) :: txj,tyj,tzj + real(kind=8) :: ccsq,cc,xysq + real(kind=8) :: bsqk,bk,cosine + real(kind=8) :: dsqj,gi,pix2 + real(kind=8) :: therk,dk,gk + real(kind=8) :: risqk,rik + real(kind=8) :: radius(2*nres) !(maxatm) (maxatm=maxres2) + real(kind=8) :: ri(maxarc),risq(maxarc) + real(kind=8) :: ux(maxarc),uy(maxarc),uz(maxarc) + real(kind=8) :: xc(maxarc),yc(maxarc),zc(maxarc) + real(kind=8) :: xc1(maxarc),yc1(maxarc),zc1(maxarc) + real(kind=8) :: dsq(maxarc),bsq(maxarc) + real(kind=8) :: dsq1(maxarc),bsq1(maxarc) + real(kind=8) :: arci(maxarc),arcf(maxarc) + real(kind=8) :: ex(maxarc),lt(maxarc),gr(maxarc) + real(kind=8) :: b(maxarc),b1(maxarc),bg(maxarc) + real(kind=8) :: kent(maxarc),kout(maxarc) + real(kind=8) :: ther(maxarc) + logical :: moved,top + logical :: omit(maxarc) +! +! include 'sizes.i' + maxatm = 2*nres !maxres2 maxres2=2*maxres + maxlight = 8*maxatm + maxbnd = 2*maxatm + maxang = 3*maxatm + maxtors = 4*maxatm +! +! zero out the surface area for the sphere of interest +! + area = 0.0d0 +! write (2,*) "ir",ir," radius",radius(ir) + if (radius(ir) .eq. 0.0d0) return +! +! set the overlap significance and connectivity shift +! + pix2 = 2.0d0 * pi + delta = 1.0d-8 + delta2 = delta * delta + eps = 1.0d-8 + moved = .false. + rmove = 1.0d-8 +! +! store coordinates and radius of the sphere of interest +! + xr = c(1,ir) + yr = c(2,ir) + zr = c(3,ir) + rr = radius(ir) + rrsq = rr * rr +! +! initialize values of some counters and summations +! + 10 continue + io = 0 + jb = 0 + ib = 0 + arclen = 0.0d0 + exang = 0.0d0 +! +! test each sphere to see if it overlaps the sphere of interest +! + do i = 1, 2*nres + if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 + rplus = rr + radius(i) + tx = c(1,i) - xr + if (abs(tx) .ge. rplus) goto 30 + ty = c(2,i) - yr + if (abs(ty) .ge. rplus) goto 30 + tz = c(3,i) - zr + if (abs(tz) .ge. rplus) goto 30 +! +! check for sphere overlap by testing distance against radii +! + xysq = tx*tx + ty*ty + if (xysq .lt. delta2) then + tx = delta + ty = 0.0d0 + xysq = delta2 + end if + ccsq = xysq + tz*tz + cc = sqrt(ccsq) + if (rplus-cc .le. delta) goto 30 + rminus = rr - radius(i) +! +! check to see if sphere of interest is completely buried +! + if (cc-abs(rminus) .le. delta) then + if (rminus .le. 0.0d0) goto 170 + goto 30 + end if +! +! check for too many overlaps with sphere of interest +! + if (io .ge. maxarc) then + write (iout,20) + 20 format (/,' SURFATOM -- Increase the Value of MAXARC') + stop + end if +! +! get overlap between current sphere and sphere of interest +! + io = io + 1 + xc1(io) = tx + yc1(io) = ty + zc1(io) = tz + dsq1(io) = xysq + bsq1(io) = ccsq + b1(io) = cc + gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) + intag1(io) = i + omit(io) = .false. + 30 continue + end do +! +! case where no other spheres overlap the sphere of interest +! + if (io .eq. 0) then + area = 4.0d0 * pi * rrsq + return + end if +! +! case where only one sphere overlaps the sphere of interest +! + if (io .eq. 1) then + area = pix2 * (1.0d0 + gr(1)) + area = mod(area,4.0d0*pi) * rrsq + return + end if +! +! case where many spheres intersect the sphere of interest; +! sort the intersecting spheres by their degree of overlap +! + call sort2 (io,gr,key) + do i = 1, io + k = key(i) + intag(i) = intag1(k) + xc(i) = xc1(k) + yc(i) = yc1(k) + zc(i) = zc1(k) + dsq(i) = dsq1(k) + b(i) = b1(k) + bsq(i) = bsq1(k) + end do +! +! get radius of each overlap circle on surface of the sphere +! + do i = 1, io + gi = gr(i) * rr + bg(i) = b(i) * gi + risq(i) = rrsq - gi*gi + ri(i) = sqrt(risq(i)) + ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) + end do +! +! find boundary of inaccessible area on sphere of interest +! + do k = 1, io-1 + if (.not. omit(k)) then + txk = xc(k) + tyk = yc(k) + tzk = zc(k) + bk = b(k) + therk = ther(k) +! +! check to see if J circle is intersecting K circle; +! get distance between circle centers and sum of radii +! + do j = k+1, io + if (omit(j)) goto 60 + cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) + cc = acos(min(1.0d0,max(-1.0d0,cc))) + td = therk + ther(j) +! +! check to see if circles enclose separate regions +! + if (cc .ge. td) goto 60 +! +! check for circle J completely inside circle K +! + if (cc+ther(j) .lt. therk) goto 40 +! +! check for circles that are essentially parallel +! + if (cc .gt. delta) goto 50 + 40 continue + omit(j) = .true. + goto 60 +! +! check to see if sphere of interest is completely buried +! + 50 continue + if (pix2-cc .le. td) goto 170 + 60 continue + end do + end if + end do +! +! find T value of circle intersections +! + do k = 1, io + if (omit(k)) goto 110 + omit(k) = .true. + narc = 0 + top = .false. + txk = xc(k) + tyk = yc(k) + tzk = zc(k) + dk = sqrt(dsq(k)) + bsqk = bsq(k) + bk = b(k) + gk = gr(k) * rr + risqk = risq(k) + rik = ri(k) + therk = ther(k) +! +! rotation matrix elements +! + t1 = tzk / (bk*dk) + axx = txk * t1 + axy = tyk * t1 + axz = dk / bk + ayx = tyk / dk + ayy = txk / dk + azx = txk / bk + azy = tyk / bk + azz = tzk / bk + do j = 1, io + if (.not. omit(j)) then + txj = xc(j) + tyj = yc(j) + tzj = zc(j) +! +! rotate spheres so K vector colinear with z-axis +! + uxj = txj*axx + tyj*axy - tzj*axz + uyj = tyj*ayy - txj*ayx + uzj = txj*azx + tyj*azy + tzj*azz + cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) + if (acos(cosine) .lt. therk+ther(j)) then + dsqj = uxj*uxj + uyj*uyj + tb = uzj*gk - bg(j) + txb = uxj * tb + tyb = uyj * tb + td = rik * dsqj + tr2 = risqk*dsqj - tb*tb + tr2 = max(eps,tr2) + tr = sqrt(tr2) + txr = uxj * tr + tyr = uyj * tr +! +! get T values of intersection for K circle +! + tb = (txb+tyr) / td + tb = min(1.0d0,max(-1.0d0,tb)) + tk1 = acos(tb) + if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 + tb = (txb-tyr) / td + tb = min(1.0d0,max(-1.0d0,tb)) + tk2 = acos(tb) + if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 + thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) + if (abs(thec) .lt. 1.0d0) then + the = -acos(thec) + else if (thec .ge. 1.0d0) then + the = 0.0d0 + else if (thec .le. -1.0d0) then + the = -pi + end if +! +! see if "tk1" is entry or exit point; check t=0 point; +! "ti" is exit point, "tf" is entry point +! + cosine = min(1.0d0,max(-1.0d0, & + (uzj*gk-uxj*rik)/(b(j)*rr))) + if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then + ti = tk2 + tf = tk1 + else + ti = tk2 + tf = tk1 + end if + narc = narc + 1 + if (narc .ge. maxarc) then + write (iout,70) + 70 format (/,' SURFATOM -- Increase the Value',& + ' of MAXARC') + stop + end if + if (tf .le. ti) then + arcf(narc) = tf + arci(narc) = 0.0d0 + tf = pix2 + lt(narc) = j + ex(narc) = the + top = .true. + narc = narc + 1 + end if + arcf(narc) = tf + arci(narc) = ti + lt(narc) = j + ex(narc) = the + ux(j) = uxj + uy(j) = uyj + uz(j) = uzj + end if + end if + end do + omit(k) = .false. +! +! special case; K circle without intersections +! + if (narc .le. 0) goto 90 +! +! general case; sum up arclength and set connectivity code +! + call sort2 (narc,arci,key) + arcsum = arci(1) + mi = key(1) + t = arcf(mi) + ni = mi + if (narc .gt. 1) then + do j = 2, narc + m = key(j) + if (t .lt. arci(j)) then + arcsum = arcsum + arci(j) - t + exang = exang + ex(ni) + jb = jb + 1 + if (jb .ge. maxarc) then + write (iout,80) + 80 format (/,' SURFATOM -- Increase the Value',& + ' of MAXARC') + stop + end if + i = lt(ni) + kent(jb) = maxarc*i + k + i = lt(m) + kout(jb) = maxarc*k + i + end if + tt = arcf(m) + if (tt .ge. t) then + t = tt + ni = m + end if + end do + end if + arcsum = arcsum + pix2 - t + if (.not. top) then + exang = exang + ex(ni) + jb = jb + 1 + i = lt(ni) + kent(jb) = maxarc*i + k + i = lt(mi) + kout(jb) = maxarc*k + i + end if + goto 100 + 90 continue + arcsum = pix2 + ib = ib + 1 + 100 continue + arclen = arclen + gr(k)*arcsum + 110 continue + end do + if (arclen .eq. 0.0d0) goto 170 + if (jb .eq. 0) goto 150 +! +! find number of independent boundaries and check connectivity +! + j = 0 + do k = 1, jb + if (kout(k) .ne. 0) then + i = k + 120 continue + m = kout(i) + kout(i) = 0 + j = j + 1 + do ii = 1, jb + if (m .eq. kent(ii)) then + if (ii .eq. k) then + ib = ib + 1 + if (j .eq. jb) goto 150 + goto 130 + end if + i = ii + goto 120 + end if + end do + 130 continue + end if + end do + ib = ib + 1 +! +! attempt to fix connectivity error by moving atom slightly +! + if (moved) then + write (iout,140) ir + 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6) + else + moved = .true. + xr = xr + rmove + yr = yr + rmove + zr = zr + rmove + goto 10 + end if +! +! compute the exposed surface area for the sphere of interest +! + 150 continue + area = ib*pix2 + exang + arclen + area = mod(area,4.0d0*pi) * rrsq +! +! attempt to fix negative area by moving atom slightly +! + if (area .lt. 0.0d0) then + if (moved) then + write (iout,160) ir + 160 format (/,' SURFATOM -- Negative Area at Atom',i6) + else + moved = .true. + xr = xr + rmove + yr = yr + rmove + zr = zr + rmove + goto 10 + end if + end if + 170 continue + return + end subroutine surfatom +!---------------------------------------------------------------- +!---------------------------------------------------------------- + subroutine alloc_MD_arrays +!EL Allocation of arrays used by MD module + + integer :: nres2,nres6 + nres2=nres*2 + nres6=nres*6 +!---------------------- +#ifndef LANG0 +! commom.langevin +! common /langforc/ + allocate(friction(3,0:nres2),stochforc(3,0:nres2)) !(3,0:MAXRES2) + allocate(fric_work(nres6),stoch_work(nres6),fricgam(nres6)) !(MAXRES6) + if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) + allocate(fricvec(nres2,nres2)) + allocate(pfric_mat(nres2,nres2),vfric_mat(nres2,nres2)) + allocate(afric_mat(nres2,nres2),prand_mat(nres2,nres2)) + allocate(vrand_mat1(nres2,nres2),vrand_mat2(nres2,nres2)) !(MAXRES2,MAXRES2) + allocate(pfric0_mat(nres2,nres2,0:maxflag_stoch)) + allocate(afric0_mat(nres2,nres2,0:maxflag_stoch)) + allocate(vfric0_mat(nres2,nres2,0:maxflag_stoch)) + allocate(prand0_mat(nres2,nres2,0:maxflag_stoch)) + allocate(vrand0_mat1(nres2,nres2,0:maxflag_stoch)) + allocate(vrand0_mat2(nres2,nres2,0:maxflag_stoch)) !(MAXRES2,MAXRES2,0:maxflag_stoch) + allocate(flag_stoch(0:maxflag_stoch)) !(0:maxflag_stoch) +! common /langmat/ + allocate(mt1(nres2,nres2),mt2(nres2,nres2),mt3(nres2,nres2)) !(maxres2,maxres2) +!---------------------- +#else +! commom.langevin.lang0 +! common /langforc/ + allocate(friction(3,0:nres2),stochforc(3,0:nres2)) !(3,0:MAXRES2) + if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) + allocate(fricvec(nres2,nres2)) !(MAXRES2,MAXRES2) + allocate(fric_work(nres6),stoch_work(nres6),fricgam(nres6)) !(MAXRES6) + allocate(flag_stoch(0:maxflag_stoch)) !(0:maxflag_stoch) +#endif + +!el if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2)) +!---------------------- +! commom.hairpin in CSA module +!---------------------- +! common.mce in MCM_MD module +!---------------------- +! common.MD +! common /mdgrad/ in module.energy +! common /back_constr/ in module.energy +! common /qmeas/ in module.energy +! common /mdpar/ +! common /MDcalc/ + allocate(potEcomp(0:n_ene+4)) !(0:n_ene+4) +! common /lagrange/ + allocate(d_t(3,0:nres2),d_a(3,0:nres2),d_t_old(3,0:nres2)) !(3,0:MAXRES2) + allocate(d_a_work(nres6)) !(6*MAXRES) + allocate(Gmat(nres2,nres2),A(nres2,nres2)) + if(.not.allocated(Ginv)) allocate(Ginv(nres2,nres2)) !in control: ergastulum + allocate(Gsqrp(nres2,nres2),Gsqrm(nres2,nres2),Gvec(nres2,nres2)) !(maxres2,maxres2) + allocate(Geigen(nres2)) !(maxres2) + if(.not.allocated(vtot)) allocate(vtot(nres2)) !(maxres2) +! common /inertia/ in io_conf: parmread +! real(kind=8),dimension(:),allocatable :: ISC,msc !(ntyp+1) +! common /langevin/in io read_MDpar +! real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1) +! real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp) +! in io_conf: parmread +! real(kind=8),dimension(:),allocatable :: restok !(ntyp+1) +! common /mdpmpi/ in control: ergastulum + if(.not.allocated(ng_start)) allocate(ng_start(0:nfgtasks-1)) + if(.not.allocated(ng_counts)) allocate(ng_counts(0:nfgtasks-1)) + if(.not.allocated(nginv_counts)) allocate(nginv_counts(0:nfgtasks-1)) !(0:MaxProcs-1) + if(.not.allocated(nginv_start)) allocate(nginv_start(0:nfgtasks)) !(0:MaxProcs) +!---------------------- +! common.muca in read_muca +! common /double_muca/ +! real(kind=8) :: elow,ehigh,factor,hbin,factor_min +! real(kind=8),dimension(:),allocatable :: emuca,nemuca,& +! nemuca2,hist !(4*maxres) +! common /integer_muca/ +! integer :: nmuca,imtime,muca_smooth +! common /mucarem/ +! real(kind=8),dimension(:),allocatable :: elowi,ehighi !(maxprocs) +!---------------------- +! common.MD +! common /mdgrad/ in module.energy +! common /back_constr/ in module.energy +! common /qmeas/ in module.energy +! common /mdpar/ +! common /MDcalc/ +! common /lagrange/ + allocate(d_t_work(nres6),d_t_work_new(nres6),d_af_work(nres6)) + allocate(d_as_work(nres6),kinetic_force(nres6)) !(MAXRES6) + allocate(d_t_new(3,0:nres2),d_a_old(3,0:nres2),d_a_short(3,0:nres2)) !,d_a !(3,0:MAXRES2) + allocate(stdforcp(nres),stdforcsc(nres)) !(MAXRES) +!---------------------- +! COMMON /BANII/ D + allocate(D_ban(nres6)) !(MAXRES6) maxres6=6*maxres +! common /stochcalc/ stochforcvec + allocate(stochforcvec(nres6)) !(MAXRES6) maxres6=6*maxres +!---------------------- + return + end subroutine alloc_MD_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module MDyn diff --git a/source/unres/MD.f90 b/source/unres/MD.f90 deleted file mode 100644 index c509ee1..0000000 --- a/source/unres/MD.f90 +++ /dev/null @@ -1,5680 +0,0 @@ - module MDyn -!----------------------------------------------------------------------------- - use io_units - use names - use math - use md_calc - use geometry_data - use io_base - use geometry - use energy - use MD_data - use REMD - - implicit none -!----------------------------------------------------------------------------- -! common.MD -! common /mdgrad/ in module.energy -! common /back_constr/ in module.energy -! common /qmeas/ in module.energy -! common /mdpar/ -! common /MDcalc/ -! common /lagrange/ - real(kind=8),dimension(:),allocatable :: d_t_work,& - d_t_work_new,d_af_work,d_as_work,kinetic_force !(MAXRES6) - real(kind=8),dimension(:,:),allocatable :: d_t_new,& - d_a_old,d_a_short!,d_a !(3,0:MAXRES2) -! real(kind=8),dimension(:),allocatable :: d_a_work !(6*MAXRES) -! real(kind=8),dimension(:,:),allocatable :: Gmat,Ginv,A,& -! Gsqrp,Gsqrm,Gvec !(maxres2,maxres2) -! real(kind=8),dimension(:),allocatable :: Geigen !(maxres2) -! integer :: dimen,dimen1,dimen3 -! integer :: lang,count_reset_moment,count_reset_vel -! logical :: reset_moment,reset_vel,rattle,RESPA -! common /inertia/ -! common /langevin/ -! real(kind=8) :: rwat,etawat,stdfp,cPoise -! real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1) -! real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp) - real(kind=8),dimension(:),allocatable :: stdforcp,stdforcsc !(MAXRES) -!----------------------------------------------------------------------------- -! 'sizes.i' -! -! -! ################################################### -! ## COPYRIGHT (C) 1992 by Jay William Ponder ## -! ## All Rights Reserved ## -! ################################################### -! -! ############################################################# -! ## ## -! ## sizes.i -- parameter values to set array dimensions ## -! ## ## -! ############################################################# -! -! -! "sizes.i" sets values for critical array dimensions used -! throughout the software; these parameters will fix the size -! of the largest systems that can be handled; values too large -! for the computer's memory and/or swap space to accomodate -! will result in poor performance or outright failure -! -! parameter: maximum allowed number of: -! -! maxatm atoms in the molecular system -! maxval atoms directly bonded to an atom -! maxgrp ! user-defined groups of atoms -! maxtyp force field atom type definitions -! maxclass force field atom class definitions -! maxkey lines in the keyword file -! maxrot bonds for torsional rotation -! maxvar optimization variables (vector storage) -! maxopt optimization variables (matrix storage) -! maxhess off-diagonal Hessian elements -! maxlight sites for method of lights neighbors -! maxvib vibrational frequencies -! maxgeo distance geometry points -! maxcell unit cells in replicated crystal -! maxring 3-, 4-, or 5-membered rings -! maxfix geometric restraints -! maxbio biopolymer atom definitions -! maxres residues in the macromolecule -! maxamino amino acid residue types -! maxnuc nucleic acid residue types -! maxbnd covalent bonds in molecular system -! maxang bond angles in molecular system -! maxtors torsional angles in molecular system -! maxpi atoms in conjugated pisystem -! maxpib covalent bonds involving pisystem -! maxpit torsional angles involving pisystem -! -! -!el integer maxatm,maxval,maxgrp -!el integer maxtyp,maxclass,maxkey -!el integer maxrot,maxopt -!el integer maxhess,maxlight,maxvib -!el integer maxgeo,maxcell,maxring -!el integer maxfix,maxbio -!el integer maxamino,maxnuc,maxbnd -!el integer maxang,maxtors,maxpi -!el integer maxpib,maxpit - integer :: maxatm !=2*nres !maxres2 maxres2=2*maxres - integer,parameter :: maxval=8 - integer,parameter :: maxgrp=1000 - integer,parameter :: maxtyp=3000 - integer,parameter :: maxclass=500 - integer,parameter :: maxkey=10000 - integer,parameter :: maxrot=1000 - integer,parameter :: maxopt=1000 - integer,parameter :: maxhess=1000000 - integer :: maxlight !=8*maxatm - integer,parameter :: maxvib=1000 - integer,parameter :: maxgeo=1000 - integer,parameter :: maxcell=10000 - integer,parameter :: maxring=10000 - integer,parameter :: maxfix=10000 - integer,parameter :: maxbio=10000 - integer,parameter :: maxamino=31 - integer,parameter :: maxnuc=12 - integer :: maxbnd !=2*maxatm - integer :: maxang !=3*maxatm - integer :: maxtors !=4*maxatm - integer,parameter :: maxpi=100 - integer,parameter :: maxpib=2*maxpi - integer,parameter :: maxpit=4*maxpi -!----------------------------------------------------------------------------- -! Maximum number of seed - integer,parameter :: max_seed=1 -!----------------------------------------------------------------------------- - real(kind=8),dimension(:),allocatable :: stochforcvec !(MAXRES6) maxres6=6*maxres -! common /stochcalc/ stochforcvec -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: rattle1,rattle2,rattle_brown - real(kind=8),dimension(:,:),allocatable :: GGinv !(2*nres,2*nres) maxres2=2*maxres - real(kind=8),dimension(:,:,:),allocatable :: gdc !(3,2*nres,2*nres) maxres2=2*maxres - real(kind=8),dimension(:,:),allocatable :: Cmat !(2*nres,2*nres) maxres2=2*maxres -!----------------------------------------------------------------------------- -! common /syfek/ subroutines: friction_force,setup_fricmat -!el real(kind=8),dimension(:),allocatable :: gamvec !(MAXRES6) or (MAXRES2) -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: friction_force,setup_fricmat - real(kind=8),dimension(:,:),allocatable :: ginvfric !(2*nres,2*nres) !maxres2=2*maxres -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutine: setup_fricmat -!el real(kind=8),dimension(:,:),allocatable :: fcopy !(2*nres,2*nres) -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! brown_step.f -!----------------------------------------------------------------------------- - subroutine brown_step(itime) -!------------------------------------------------ -! Perform a single Euler integration step of Brownian dynamics -!------------------------------------------------ -! implicit real*8 (a-h,o-z) - use comm_gucio - use control, only: tcpu - use control_data - use energy_data -! use io_conf, only:cartprint -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8),dimension(6*nres) :: zapas !(MAXRES6) maxres6=6*maxres - integer :: rstcount !ilen, -!el external ilen -!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres - real(kind=8),dimension(6*nres,2*nres) :: Bmat,GBmat,Tmat !(MAXRES6,MAXRES2) (maxres2=2*maxres,maxres6=6*maxres) - real(kind=8),dimension(2*nres,2*nres) :: Cmat_,Cinv !(maxres2,maxres2) maxres2=2*maxres - real(kind=8),dimension(6*nres,6*nres) :: Pmat !(maxres6,maxres6) maxres6=6*maxres - real(kind=8),dimension(6*nres) :: Td !(maxres6) maxres6=6*maxres - real(kind=8),dimension(2*nres) :: ppvec !(maxres2) maxres2=2*maxres -!el common /stochcalc/ stochforcvec -!el real(kind=8),dimension(3) :: cm !el -!el common /gucio/ cm - integer :: itime - logical :: lprn = .false.,lprn1 = .false. - integer :: maxiter = 5 - real(kind=8) :: difftol = 1.0d-5 - real(kind=8) :: xx,diffmax,blen2,diffbond,tt0 - integer :: i,j,nbond,k,ind,ind1,iter - integer :: nres2,nres6 - logical :: osob - nres2=2*nres - nres6=6*nres - - if (.not.allocated(stochforcvec)) allocate(stochforcvec(nres6)) !(MAXRES6) maxres6=6*maxres - - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -! - if (lprn1) then - write (iout,*) "Generalized inverse of fricmat" - call matout(dimen,dimen,nres6,nres6,fricmat) - endif - do i=1,dimen - do j=1,nbond - Bmat(i,j)=0.0d0 - enddo - enddo - ind=3 - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - Bmat(ind+j,ind1)=dC_norm(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - Bmat(ind+j,ind1)=dC_norm(j,i+nres) - enddo - ind=ind+3 - endif - enddo - if (lprn1) then - write (iout,*) "Matrix Bmat" - call MATOUT(nbond,dimen,nres6,nres6,Bmat) - endif - do i=1,dimen - do j=1,nbond - GBmat(i,j)=0.0d0 - do k=1,dimen - GBmat(i,j)=GBmat(i,j)+fricmat(i,k)*Bmat(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix GBmat" - call MATOUT(nbond,dimen,nres6,nres2,Gbmat) - endif - do i=1,nbond - do j=1,nbond - Cmat_(i,j)=0.0d0 - do k=1,dimen - Cmat_(i,j)=Cmat_(i,j)+Bmat(k,i)*GBmat(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,nres2,nres2,Cmat_) - endif - call matinvert(nbond,nres2,Cmat_,Cinv,osob) - if (lprn1) then - write (iout,*) "Matrix Cinv" - call MATOUT(nbond,nbond,nres2,nres2,Cinv) - endif - do i=1,dimen - do j=1,nbond - Tmat(i,j)=0.0d0 - do k=1,nbond - Tmat(i,j)=Tmat(i,j)+GBmat(i,k)*Cinv(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Tmat" - call MATOUT(nbond,dimen,nres6,nres2,Tmat) - endif - do i=1,dimen - do j=1,dimen - if (i.eq.j) then - Pmat(i,j)=1.0d0 - else - Pmat(i,j)=0.0d0 - endif - do k=1,nbond - Pmat(i,j)=Pmat(i,j)-Tmat(i,k)*Bmat(j,k) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Pmat" - call MATOUT(dimen,dimen,nres6,nres6,Pmat) - endif - do i=1,dimen - Td(i)=0.0d0 - ind=0 - do k=nnt,nct-1 - ind=ind+1 - Td(i)=Td(i)+vbl*Tmat(i,ind) - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - Td(i)=Td(i)+vbldsc0(1,itype(k))*Tmat(i,ind) - endif - enddo - enddo - if (lprn1) then - write (iout,*) "Vector Td" - do i=1,dimen - write (iout,'(i5,f10.5)') i,Td(i) - enddo - endif - call stochastic_force(stochforcvec) - if (lprn) then - write (iout,*) "stochforcvec" - do i=1,dimen - write (iout,*) i,stochforcvec(i) - enddo - endif - do j=1,3 - zapas(j)=-gcart(j,0)+stochforcvec(j) - d_t_work(j)=d_t(j,0) - dC_work(j)=dC_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - zapas(ind)=-gcart(j,i)+stochforcvec(ind) - dC_work(ind)=dC_old(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - zapas(ind)=-gxcart(j,i)+stochforcvec(ind) - dC_work(ind)=dC_old(j,i+nres) - enddo - endif - enddo - - if (lprn) then - write (iout,*) "Initial d_t_work" - do i=1,dimen - write (iout,*) i,d_t_work(i) - enddo - endif - - do i=1,dimen - d_t_work(i)=0.0d0 - do j=1,dimen - d_t_work(i)=d_t_work(i)+fricmat(i,j)*zapas(j) - enddo - enddo - - do i=1,dimen - zapas(i)=Td(i) - do j=1,dimen - zapas(i)=zapas(i)+Pmat(i,j)*(dC_work(j)+d_t_work(j)*d_time) - enddo - enddo - if (lprn1) then - write (iout,*) "Final d_t_work and zapas" - do i=1,dimen - write (iout,*) i,d_t_work(i),zapas(i) - enddo - endif - - do j=1,3 - d_t(j,0)=d_t_work(j) - dc(j,0)=zapas(j) - dc_work(j)=dc(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(i) - dc(j,i)=zapas(ind+j) - dc_work(ind+j)=dc(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - d_t(j,i+nres)=d_t_work(ind+j) - dc(j,i+nres)=zapas(ind+j) - dc_work(ind+j)=dc(j,i+nres) - enddo - ind=ind+3 - enddo - if (lprn) then - call chainbuild_cart - write (iout,*) "Before correction for rotational lengthening" - write (iout,*) "New coordinates",& - " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)-vbl - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i),j=1,3),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)-vbldsc0(1,itype(i)) - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i+nres),j=1,3),xx - endif - enddo - endif -! Second correction (rotational lengthening) -! do iter=1,maxiter - diffmax=0.0d0 - ind=0 - do i=nnt,nct-1 - ind=ind+1 - blen2 = scalar(dc(1,i),dc(1,i)) - ppvec(ind)=2*vbl**2-blen2 - diffbond=dabs(vbl-dsqrt(blen2)) - if (diffbond.gt.diffmax) diffmax=diffbond - if (ppvec(ind).gt.0.0d0) then - ppvec(ind)=dsqrt(ppvec(ind)) - else - ppvec(ind)=0.0d0 - endif - if (lprn) then - write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) - endif - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - blen2 = scalar(dc(1,i+nres),dc(1,i+nres)) - ppvec(ind)=2*vbldsc0(1,itype(i))**2-blen2 - diffbond=dabs(vbldsc0(1,itype(i))-dsqrt(blen2)) - if (diffbond.gt.diffmax) diffmax=diffbond - if (ppvec(ind).gt.0.0d0) then - ppvec(ind)=dsqrt(ppvec(ind)) - else - ppvec(ind)=0.0d0 - endif - if (lprn) then - write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) - endif - endif - enddo - if (lprn) write (iout,*) "iter",iter," diffmax",diffmax - if (diffmax.lt.difftol) goto 10 - do i=1,dimen - Td(i)=0.0d0 - do j=1,nbond - Td(i)=Td(i)+ppvec(j)*Tmat(i,j) - enddo - enddo - do i=1,dimen - zapas(i)=Td(i) - do j=1,dimen - zapas(i)=zapas(i)+Pmat(i,j)*dc_work(j) - enddo - enddo - do j=1,3 - dc(j,0)=zapas(j) - dc_work(j)=zapas(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=zapas(ind+j) - dc_work(ind+j)=zapas(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=zapas(ind+j) - dc_work(ind+j)=zapas(ind+j) - enddo - ind=ind+3 - endif - enddo -! Building the chain from the newly calculated coordinates - call chainbuild_cart - if(ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,'(a)') "Potential forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(-gcart(j,i),j=1,3),& - (-gxcart(j,i),j=1,3) - enddo - write (iout,'(a)') "Stochastic forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(stochforc(j,i),j=1,3),& - (stochforc(j,i+nres),j=1,3) - enddo - write (iout,'(a)') "Velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif - if (lprn) then - write (iout,*) "After correction for rotational lengthening" - write (iout,*) "New coordinates",& - " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)-vbl - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i),j=1,3),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)-vbldsc0(1,itype(i)) - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i+nres),j=1,3),xx - endif - enddo - endif -! ENDDO -! write (iout,*) "Too many attempts at correcting the bonds" -! stop - 10 continue -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -! Calculate energy and forces - call zerograd - call etotal(potEcomp) - potE=potEcomp(0)-potEcomp(20) - call cartgrad - totT=totT+d_time -! Calculate the kinetic and total energy and the kinetic temperature - call kinetic(EK) -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - totE=EK+potE - kinetic_T=2.0d0/(dimen*Rb)*EK - return - end subroutine brown_step -!----------------------------------------------------------------------------- -! gauss.f -!----------------------------------------------------------------------------- - subroutine gauss(RO,AP,MT,M,N,*) -! -! CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION -! RO IS A SQUARE MATRIX -! THE CALCULATED PRODUCT IS STORED IN AP -! ABNORMAL EXIT IF RO IS SINGULAR -! - integer :: MT, M, N, M1,I,J,IM,& - I1,MI,MI1 - real(kind=8) :: RO(MT,M),AP(MT,N),X,RM,PR,Y - integer :: k -! real(kind=8) :: - - if(M.ne.1)goto 10 - X=RO(1,1) - if(dabs(X).le.1.0D-13) return 1 - X=1.0/X - do 16 I=1,N -16 AP(1,I)=AP(1,I)*X - return -10 continue - M1=M-1 - DO 1 I=1,M1 - IM=I - RM=DABS(RO(I,I)) - I1=I+1 - do 2 J=I1,M - if(DABS(RO(J,I)).LE.RM) goto 2 - RM=DABS(RO(J,I)) - IM=J -2 continue - If(IM.eq.I)goto 17 - do 3 J=1,N - PR=AP(I,J) - AP(I,J)=AP(IM,J) -3 AP(IM,J)=PR - do 4 J=I,M - PR=RO(I,J) - RO(I,J)=RO(IM,J) -4 RO(IM,J)=PR -17 X=RO(I,I) - if(dabs(X).le.1.0E-13) return 1 - X=1.0/X - do 5 J=1,N -5 AP(I,J)=X*AP(I,J) - do 6 J=I1,M -6 RO(I,J)=X*RO(I,J) - do 7 J=I1,M - Y=RO(J,I) - do 8 K=1,N -8 AP(J,K)=AP(J,K)-Y*AP(I,K) - do 9 K=I1,M -9 RO(J,K)=RO(J,K)-Y*RO(I,K) -7 continue -1 continue - X=RO(M,M) - if(dabs(X).le.1.0E-13) return 1 - X=1.0/X - do 11 J=1,N -11 AP(M,J)=X*AP(M,J) - do 12 I=1,M1 - MI=M-I - MI1=MI+1 - do 14 J=1,N - X=AP(MI,J) - do 15 K=MI1,M -15 X=X-AP(K,J)*RO(MI,K) -14 AP(MI,J)=X -12 continue - return - end subroutine gauss -!----------------------------------------------------------------------------- -! kinetic_lesyng.f -!----------------------------------------------------------------------------- - subroutine kinetic(KE_total) -!---------------------------------------------------------------- -! This subroutine calculates the total kinetic energy of the chain -!----------------------------------------------------------------- - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' - real(kind=8) :: KE_total - - integer :: i,j,k,iti - real(kind=8) :: KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3),& - mag1,mag2,v(3) - - KEt_p=0.0d0 - KEt_sc=0.0d0 -! write (iout,*) "ISC",(isc(itype(i)),i=1,nres) -! The translational part for peptide virtual bonds - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 -! write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -! write(iout,*) 'KEt_p', KEt_p -! The translational part for the side chain virtual bond -! Only now we can initialize incr with zeros. It must be equal -! to the velocities of the first Calpha. - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=iabs(itype(i)) - if (itype(i).eq.10) then - do j=1,3 - v(j)=incr(j) - enddo - else - do j=1,3 - v(j)=incr(j)+d_t(j,nres+i) - enddo - endif -! write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) -! write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) - KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -! goto 111 -! write(iout,*) 'KEt_sc', KEt_sc -! The part due to stretching and rotation of the peptide groups - KEr_p=0.0D0 - do i=nnt,nct-1 -! write (iout,*) "i",i -! write (iout,*) "i",i," mag1",mag1," mag2",mag2 - do j=1,3 - incr(j)=d_t(j,i) - enddo -! write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) - KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) & - +incr(3)*incr(3)) - enddo -! goto 111 -! write(iout,*) 'KEr_p', KEr_p -! The rotational part of the side chain virtual bond - KEr_sc=0.0D0 - do i=nnt,nct - iti=iabs(itype(i)) - if (itype(i).ne.10) then - do j=1,3 - incr(j)=d_t(j,nres+i) - enddo -! write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) - KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ & - incr(3)*incr(3)) - endif - enddo -! The total kinetic energy - 111 continue -! write(iout,*) 'KEr_sc', KEr_sc - KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) -! write (iout,*) "KE_total",KE_total - return - end subroutine kinetic -!----------------------------------------------------------------------------- -! MD_A-MTS.F -!----------------------------------------------------------------------------- - subroutine MD -!------------------------------------------------ -! The driver for molecular dynamics subroutines -!------------------------------------------------ - use comm_gucio -! use MPI - use control, only:tcpu,ovrtim -! use io_comm, only:ilen - use control_data - use compare, only:secondary2,hairpin - use io, only:cartout,statout -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -! include 'COMMON.HAIRPIN' - real(kind=8),dimension(3) :: L,vcm -#ifdef VOUT - real(kind=8),dimension(6*nres) :: v_work,v_transf !(maxres6) maxres6=6*maxres -#endif - integer :: rstcount !ilen, -!el external ilen - character(len=50) :: tytul -!el common /gucio/ cm - integer :: itime,i,j,nharp - integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) -! logical :: ovrtim - real(kind=8) :: tt0,scalfac - integer :: nres2 - nres2=2*nres -! -#ifdef MPI - if (ilen(tmpdir).gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" & - //liczba(:ilen(liczba))//'.rst') -#else - if (ilen(tmpdir).gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') -#endif - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0 = tcpu() -#endif -! Determine the inverse of the inertia matrix. - call setup_MD_matrices -! Initialize MD - call init_MD -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -! Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) & - "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - do itime=1,n_timestep - if (ovrtim()) exit - if (large.and. mod(itime,ntwe).eq.0) & - write (iout,*) "itime",itime - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. & - mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') & - "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 & - .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - write(iout,'(a,f20.2)') & - "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) - write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -! Time-reversible RESPA algorithm -! (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -! Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) -#ifdef VOUT - do j=1,3 - v_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i+nres) - enddo - endif - enddo - - write (66,'(80f10.5)') & - ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) - do i=1,ind - v_transf(i)=0.0d0 - do j=1,ind - v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) - enddo - v_transf(i)= v_transf(i)*dsqrt(geigen(i)) - enddo - write (67,'(80f10.5)') (v_transf(i),i=1,ind) -#endif - endif - if (mod(itime,ntwx).eq.0) then - write (tytul,'("time",f8.2)') totT - if(mdpdb) then - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (rstcount.eq.1000.or.itime.eq.n_timestep) then - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - enddo - -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') & - ' Timing ',& - 'MD calculations setup:',t_MDsetup,& - 'Energy & gradient evaluation:',t_enegrad,& - 'Stochastic MD setup:',t_langsetup,& - 'Stochastic MD step setup:',t_sdsetup,& - 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') & - ' End of MD calculation ' -#ifdef TIMING_ENE - write (iout,*) "time for etotal",t_etotal," elong",t_elong,& - " eshort",t_eshort - write (iout,*) "time_fric",time_fric," time_stoch",time_stoch,& - " time_fricmatmult",time_fricmatmult," time_fsample ",& - time_fsample -#endif - return - end subroutine MD -!----------------------------------------------------------------------------- - subroutine velverlet_step(itime) -!------------------------------------------------------------------------------- -! Perform a single velocity Verlet step; the time step can be rescaled if -! increments in accelerations exceed the threshold -!------------------------------------------------------------------------------- -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use comm_gucio - use control, only:tcpu - use control_data -#ifdef MPI - include 'mpif.h' - integer :: ierror,ierrcode - real(kind=8) :: errcode -#endif -! include 'COMMON.SETUP' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -! include 'COMMON.MUCA' - real(kind=8),dimension(3) :: vcm,incr - real(kind=8),dimension(3) :: L - integer :: count,rstcount !ilen, -!el external ilen - character(len=50) :: tytul - integer :: maxcount_scale = 20 -!el common /gucio/ cm -!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec - integer :: itime,icount_scale,itime_scal,i,j,ifac_time - logical :: scale - real(kind=8) :: epdrift,tt0,fac_time -! - if (.not.allocated(stochforcvec)) allocate(stochforcvec(6*nres)) !(MAXRES6) maxres6=6*maxres - - scale=.true. - icount_scale=0 - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) & - "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - itime_scal=0 - do while (scale) - icount_scale=icount_scale+1 - if (icount_scale.gt.maxcount_scale) then - write (iout,*) & - "ERROR: too many attempts at scaling down the time step. ",& - "amax=",amax,"epdrift=",epdrift,& - "damax=",damax,"edriftmax=",edriftmax,& - "d_time=",d_time - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) -#endif - stop - endif -! First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -! Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,*) "dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),& - (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -! Calculate energy and forces - call zerograd - call etotal(potEcomp) - if (large.and. mod(itime,ntwe).eq.0) & - call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_etotal=t_etotal+MPI_Wtime()-tt0 -#else - t_etotal=t_etotal+tcpu()-tt0 -#endif -#endif - potE=potEcomp(0)-potEcomp(20) - call cartgrad -! Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -! Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/(itime_scal+1)**2 - call predict_edrift(epdrift) - if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then -! Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step - scale=.true. - ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) & - /dlog(2.0d0)+1 - itime_scal=itime_scal+ifac_time -! fac_time=dmin1(damax/amax,0.5d0) - fac_time=0.5d0**ifac_time - d_time=d_time*fac_time - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 -! write (iout,*) "Calling sd_verlet_setup: 1" -! Rescale the stochastic forces and recalculate or restore -! the matrices of tinker integrator - if (itime_scal.gt.maxflag_stoch) then - if (large) write (iout,'(a,i5,a)') & - "Calculate matrices for stochastic step;",& - " itime_scal ",itime_scal - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - write (iout,'(2a,i3,a,i3,1h.)') & - "Warning: cannot store matrices for stochastic",& - " integration because the index",itime_scal,& - " is greater than",maxflag_stoch - write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct",& - " integration Langevin algorithm for better efficiency." - else if (flag_stoch(itime_scal)) then - if (large) write (iout,'(a,i5,a,l1)') & - "Restore matrices for stochastic step; itime_scal ",& - itime_scal," flag ",flag_stoch(itime_scal) - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) - afric_mat(i,j)=afric0_mat(i,j,itime_scal) - vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) - prand_mat(i,j)=prand0_mat(i,j,itime_scal) - vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) - vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) - enddo - enddo - else - if (large) write (iout,'(2a,i5,a,l1)') & - "Calculate & store matrices for stochastic step;",& - " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - flag_stoch(ifac_time)=.true. - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) - afric0_mat(i,j,itime_scal)=afric_mat(i,j) - vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) - prand0_mat(i,j,itime_scal)=prand_mat(i,j) - vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) - vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) - enddo - enddo - endif - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - stochforcvec(i)=fac_time*stochforcvec(i) - enddo -#endif - else if (lang.eq.1) then -! Rescale the accelerations due to stochastic forces - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - d_as_work(i)=d_as_work(i)*fac_time - enddo - endif - if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') & - "itime",itime," Timestep scaled down to ",& - d_time," ifac_time",ifac_time," itime_scal",itime_scal - else -! Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 - totT=totT+d_time - if (d_time.ne.d_time0) then - d_time=d_time0 -#ifndef LANG0 - if (lang.eq.2 .or. lang.eq.3) then - if (large) write (iout,'(a)') & - "Restore original matrices for stochastic step" -! write (iout,*) "Calling sd_verlet_setup: 2" -! Restore the matrices of tinker integrator if the time step has been restored - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,0) - afric_mat(i,j)=afric0_mat(i,j,0) - vfric_mat(i,j)=vfric0_mat(i,j,0) - prand_mat(i,j)=prand0_mat(i,j,0) - vrand_mat1(i,j)=vrand0_mat1(i,j,0) - vrand_mat2(i,j)=vrand0_mat2(i,j,0) - enddo - enddo - endif -#endif - endif - scale=.false. - endif - enddo -! Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -! diagnostics -! call kinetic1(EK1) -! write (iout,*) "step",itime," EK",EK," EK1",EK1 -! end diagnostics -! Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -! Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end subroutine velverlet_step -!----------------------------------------------------------------------------- - subroutine RESPA_step(itime) -!------------------------------------------------------------------------------- -! Perform a single RESPA step. -!------------------------------------------------------------------------------- -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use comm_gucio - use comm_cipiszcze -! use MPI - use control, only:tcpu - use control_data -! use io_conf, only:cartprint -#ifdef MPI - include 'mpif.h' - integer :: IERROR,ERRCODE -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8),dimension(0:n_ene) :: energia_short,energia_long - real(kind=8),dimension(3) :: L,vcm,incr - real(kind=8),dimension(3,0:2*nres) :: dc_old0,d_t_old0,d_a_old0 !(3,0:maxres2) maxres2=2*maxres - logical :: PRINT_AMTS_MSG = .false. - integer :: count,rstcount !ilen, -!el external ilen - character(len=50) :: tytul - integer :: maxcount_scale = 10 -!el common /gucio/ cm -!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec - integer :: itime,itt,i,j,itsplit - logical :: scale -!el common /cipiszcze/ itt - - real(kind=8) :: epdrift,tt0,epdriftmax - itt = itt_comm - - if (.not.allocated(stochforcvec)) allocate(stochforcvec(6*nres)) !(MAXRES6) maxres6=6*maxres - - itt=itime - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***************** RESPA itime",itime - write (iout,*) "Cartesian and internal coordinates: step 0" -! call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 0" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif -! -! Perform the initial RESPA step (increment velocities) -! write (iout,*) "*********************** RESPA ini" - call RESPA_vel - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif -! Compute the short-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -! 7/2/2009 commented out -! call zerograd -! call etotal_short(energia_short) -! call cartgrad -! call lagrangian -! 7/2/2009 Copy accelerations due to short-lange forces from previous MD step - do i=0,2*nres - do j=1,3 - d_a(j,i)=d_a_short(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo -! 6/30/08 A-MTS: attempt at increasing the split number - do i=0,2*nres - do j=1,3 - dc_old0(j,i)=dc_old(j,i) - d_t_old0(j,i)=d_t_old(j,i) - d_a_old0(j,i)=d_a_old(j,i) - enddo - enddo - if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 - if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 -! - scale=.true. - d_time0=d_time - do while (scale) - - scale=.false. -! write (iout,*) "itime",itime," ntime_split",ntime_split -! Split the time step - d_time=d_time0/ntime_split -! Perform the short-range RESPA steps (velocity Verlet increments of -! positions and velocities using short-range forces) -! write (iout,*) "*********************** RESPA split" - do itsplit=1,ntime_split - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) & - "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif -! First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -! Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***** ITSPLIT",itsplit - write (iout,*) "Cartesian and internal coordinates: step 1" - call pdbout(0.0d0,"cipiszcze",iout) -! call cartprint - call intout - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -! Calculate energy and forces - call zerograd - call etotal_short(energia_short) - if (large.and. mod(itime,ntwe).eq.0) & - call enerprint(energia_short) -#ifdef TIMING_ENE -#ifdef MPI - t_eshort=t_eshort+MPI_Wtime()-tt0 -#else - t_eshort=t_eshort+tcpu()-tt0 -#endif -#endif - call cartgrad -! Get the new accelerations - call lagrangian -! 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*)"energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - endif - endif -! 6/30/08 A-MTS -! Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/ntime_split**2 - call predict_edrift(epdrift) - if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) & - write (iout,*) "amax",amax," damax",damax,& - " epdrift",epdrift," epdriftmax",epdriftmax -! Exit loop and try with increased split number if the change of -! acceleration is too big - if (amax.gt.damax .or. epdrift.gt.edriftmax) then - if (ntime_split.lt.maxtime_split) then - scale=.true. - ntime_split=ntime_split*2 - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc_old0(j,i) - d_t_old(j,i)=d_t_old0(j,i) - d_a_old(j,i)=d_a_old0(j,i) - enddo - enddo - if (PRINT_AMTS_MSG) then - write (iout,*) "acceleration/energy drift too large",amax,& - epdrift," split increased to ",ntime_split," itime",itime,& - " itsplit",itsplit - endif - exit - else - write (iout,*) & - "Uh-hu. Bumpy landscape. Maximum splitting number",& - maxtime_split,& - " already reached!!! Trying to carry on!" - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -! Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 -! Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - enddo - - enddo ! while scale - -! Restore the time step - d_time=d_time0 -! Compute long-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if (large.and. mod(itime,ntwe).eq.0) & - call enerprint(energia_long) -#ifdef TIMING_ENE -#ifdef MPI - t_elong=t_elong+MPI_Wtime()-tt0 -#else - t_elong=t_elong+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -! Compute accelerations from long-range forces - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Cartesian and internal coordinates: step 2" -! call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif -! Compute the final RESPA step (increment velocities) -! write (iout,*) "*********************** RESPA fin" - call RESPA_vel -! Compute the complete potential energy - do i=0,n_ene - potEcomp(i)=energia_short(i)+energia_long(i) - enddo - potE=potEcomp(0)-potEcomp(20) -! potE=energia_short(0)+energia_long(0) - totT=totT+d_time -! Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -! Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -! Backup the coordinates, velocities, and accelerations - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end subroutine RESPA_step -!----------------------------------------------------------------------------- - subroutine RESPA_vel -! First and last RESPA step (incrementing velocities using long-range -! forces). - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - integer :: i,j,inres - - do j=1,3 - d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end subroutine RESPA_vel -!----------------------------------------------------------------------------- - subroutine verlet1 -! Applying velocity Verlet algorithm - step 1 to coordinates - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - real(kind=8) :: adt,adt2 - integer :: i,j,inres - -#ifdef DEBUG - write (iout,*) "VELVERLET1 START: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),& - (dc(j,i+nres),j=1,3) - enddo -#endif - do j=1,3 - adt=d_a_old(j,0)*d_time - adt2=0.5d0*adt - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+adt2 - d_t(j,0)=d_t_old(j,0)+adt - enddo - do i=nnt,nct-1 - do j=1,3 - adt=d_a_old(j,i)*d_time - adt2=0.5d0*adt - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+adt2 - d_t(j,i)=d_t_old(j,i)+adt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - adt=d_a_old(j,inres)*d_time - adt2=0.5d0*adt - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+adt2 - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - endif - enddo -#ifdef DEBUG - write (iout,*) "VELVERLET1 END: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),& - (dc(j,i+nres),j=1,3) - enddo -#endif - return - end subroutine verlet1 -!----------------------------------------------------------------------------- - subroutine verlet2 -! Step 2 of the velocity Verlet algorithm: update velocities - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - integer :: i,j,inres - - do j=1,3 - d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end subroutine verlet2 -!----------------------------------------------------------------------------- - subroutine sddir_precalc -! Applying velocity Verlet algorithm - step 1 to coordinates -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use MPI_data - use control_data -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec - real(kind=8) :: time00 -! -! Compute friction and stochastic forces -! -#ifdef MPI - time00=MPI_Wtime() - call friction_force - time_fric=time_fric+MPI_Wtime()-time00 - time00=MPI_Wtime() - call stochastic_force(stochforcvec) - time_stoch=time_stoch+MPI_Wtime()-time00 -#endif -! -! Compute the acceleration due to friction forces (d_af_work) and stochastic -! forces (d_as_work) -! - call ginv_mult(fric_work, d_af_work) - call ginv_mult(stochforcvec, d_as_work) - return - end subroutine sddir_precalc -!----------------------------------------------------------------------------- - subroutine sddir_verlet1 -! Applying velocity Verlet algorithm - step 1 to velocities -! - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! Revised 3/31/05 AL: correlation between random contributions to -! position and velocity increments included. - real(kind=8) :: sqrt13 = 0.57735026918962576451d0 ! 1/sqrt(3) - real(kind=8) :: adt,adt2 - integer :: i,j,ind,inres -! -! Add the contribution from BOTH friction and stochastic force to the -! coordinates, but ONLY the contribution from the friction forces to velocities -! - do j=1,3 - adt=(d_a_old(j,0)+d_af_work(j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt - d_t(j,0)=d_t_old(j,0)+adt - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt - d_t(j,i)=d_t_old(j,i)+adt - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - ind=ind+3 - endif - enddo - return - end subroutine sddir_verlet1 -!----------------------------------------------------------------------------- - subroutine sddir_verlet2 -! Calculating the adjusted velocities for accelerations -! - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - real(kind=8),dimension(6*nres) :: stochforcvec,d_as_work1 !(MAXRES6) maxres6=6*maxres - real(kind=8) :: cos60 = 0.5d0, sin60 = 0.86602540378443864676d0 - integer :: i,j,ind,inres -! Revised 3/31/05 AL: correlation between random contributions to -! position and velocity increments included. -! The correlation coefficients are calculated at low-friction limit. -! Also, friction forces are now not calculated with new velocities. - -! call friction_force - call stochastic_force(stochforcvec) -! -! Compute the acceleration due to friction forces (d_af_work) and stochastic -! forces (d_as_work) -! - call ginv_mult(stochforcvec, d_as_work1) - -! -! Update velocities -! - do j=1,3 - d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) & - +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) & - +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) & - +d_af_work(ind+j))+sin60*d_as_work(ind+j) & - +cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - endif - enddo - return - end subroutine sddir_verlet2 -!----------------------------------------------------------------------------- - subroutine max_accel -! -! Find the maximum difference in the accelerations of the the sites -! at the beginning and the end of the time step. -! - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' - real(kind=8),dimension(3) :: aux,accel,accel_old - real(kind=8) :: dacc - integer :: i,j - - do j=1,3 -! aux(j)=d_a(j,0)-d_a_old(j,0) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - amax=0.0d0 - do i=nnt,nct -! Backbone - if (i.lt.nct) then -! 7/3/08 changed to asymmetric difference - do j=1,3 -! accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) - accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) - accel(j)=accel(j)+0.5d0*d_a(j,i) -! if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) -! write (iout,*) i,dacc - if (dacc.gt.amax) amax=dacc - endif - enddo - endif - enddo -! Side chains - do j=1,3 -! accel(j)=aux(j) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - if (nnt.eq.2) then - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,1) - accel(j)=accel(j)+d_a(j,1) - enddo - endif - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 -! accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) - accel_old(j)=accel_old(j)+d_a_old(j,i+nres) - accel(j)=accel(j)+d_a(j,i+nres) - enddo - endif - do j=1,3 -! if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) -! write (iout,*) "side-chain",i,dacc - if (dacc.gt.amax) amax=dacc - endif - enddo - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,i) - accel(j)=accel(j)+d_a(j,i) -! aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) - enddo - enddo - return - end subroutine max_accel -!----------------------------------------------------------------------------- - subroutine predict_edrift(epdrift) -! -! Predict the drift of the potential energy -! - use energy_data - use control_data, only: lmuca -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.MUCA' - real(kind=8) :: epdrift,epdriftij - integer :: i,j -! Drift of the potential energy - epdrift=0.0d0 - do i=nnt,nct -! Backbone - if (i.lt.nct) then - do j=1,3 - epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -! write (iout,*) "back",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif -! Side chains - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - epdriftij= & - dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -! write (iout,*) "side",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif - enddo - epdrift=0.5d0*epdrift*d_time*d_time -! write (iout,*) "epdrift",epdrift - return - end subroutine predict_edrift -!----------------------------------------------------------------------------- - subroutine verlet_bath -! -! Coupling to the thermostat by using the Berendsen algorithm -! - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - real(kind=8) :: T_half,fact - integer :: i,j,inres -! - T_half=2.0d0/(dimen3*Rb)*EK - fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) -! write(iout,*) "T_half", T_half -! write(iout,*) "EK", EK -! write(iout,*) "fact", fact - do j=1,3 - d_t(j,0)=fact*d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=fact*d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=fact*d_t(j,inres) - enddo - endif - enddo - return - end subroutine verlet_bath -!----------------------------------------------------------------------------- - subroutine init_MD -! Set up the initial conditions of a MD simulation - use comm_gucio - use energy_data - use control, only:tcpu -!el use io_basic, only:ilen - use control_data - use MPI_data - use minimm, only:minim_dc,minimize,sc_move - use io_config, only:readrst - use io, only:statout -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - character(len=16) :: form - integer :: IERROR,ERRCODE -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.REMD' - real(kind=8),dimension(0:n_ene) :: energia_long,energia_short - real(kind=8),dimension(3) :: vcm,incr,L - real(kind=8) :: xv,sigv,lowb,highb - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - character(len=256) :: qstr -!el integer ilen -!el external ilen - character(len=50) :: tytul - logical :: file_exist -!el common /gucio/ cm - integer :: i,j,ipos,iq,iw,nft_sc,iretcode,nfun,itime,ierr - real(kind=8) :: etot,tt0 - logical :: fail - - d_time0=d_time -! write(iout,*) "d_time", d_time -! Compute the standard deviations of stochastic forces for Langevin dynamics -! if the friction coefficients do not depend on surface area - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(iabs(itype(i))) & - *dsqrt(gamsc(iabs(itype(i)))) - enddo - endif -! Open the pdb file for snapshotshots -#ifdef MPI - if(mdpdb) then - if (ilen(tmpdir).gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// & - liczba(:ilen(liczba))//".pdb") - open(ipdb,& - file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) & - //".pdb") - else -#ifdef NOXDR - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// & - liczba(:ilen(liczba))//".x") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) & - //".x" -#else - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// & - liczba(:ilen(liczba))//".cx") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) & - //".cx" -#endif - endif -#else - if(mdpdb) then - if (ilen(tmpdir).gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") - open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") - else - if (ilen(tmpdir).gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") - cartname=prefix(:ilen(prefix))//"_MD.cx" - endif -#endif - if (usampl) then - write (qstr,'(256(1h ))') - ipos=1 - do i=1,nfrag - iq = qinfrag(i,iset)*10 - iw = wfrag(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) & - write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo - do i=1,npair - iq = qinpair(i,iset)*10 - iw = wpair(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) & - write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo -! pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' -#ifdef NOXDR -! cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' -#else -! cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' -#endif -! statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' - endif - icg=1 - if (rest) then - if (restart1file) then - if (me.eq.king) & - inquire(file=mremd_rst_name,exist=file_exist) - write (*,*) me," Before broadcast: file_exist",file_exist -#ifdef MPI !el - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,& - IERR) -#endif !el - write (*,*) me," After broadcast: file_exist",file_exist -! inquire(file=mremd_rst_name,exist=file_exist) - if(me.eq.king.or..not.out1file) & - write(iout,*) "Initial state read by master and distributed" - else - if (ilen(tmpdir).gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' & - //liczba(:ilen(liczba))//'.rst') - inquire(file=rest2name,exist=file_exist) - endif - if(file_exist) then - if(.not.restart1file) then - if(me.eq.king.or..not.out1file) & - write(iout,*) "Initial state will be read from file ",& - rest2name(:ilen(rest2name)) - call readrst - endif - call rescale_weights(t_bath) - else - if(me.eq.king.or..not.out1file)then - if (restart1file) then - write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)),& - " does not exist" - else - write(iout,*) "File ",rest2name(:ilen(rest2name)),& - " does not exist" - endif - write(iout,*) "Initial velocities randomly generated" - endif - call random_vel - totT=0.0d0 - endif - else -! Generate initial velocities - if(me.eq.king.or..not.out1file) & - write(iout,*) "Initial velocities randomly generated" - call random_vel - totT=0.0d0 - endif -! rest2name = prefix(:ilen(prefix))//'.rst' - if(me.eq.king.or..not.out1file)then - write (iout,*) "Initial velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo -! Zeroing the total angular momentum of the system - write(iout,*) "Calling the zero-angular momentum subroutine" - endif - call inertia_tensor -! Getting the potential energy and forces and velocities and accelerations - call vcm_vel(vcm) -! write (iout,*) "velocity of the center of the mass:" -! write (iout,*) (vcm(j),j=1,3) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo -! Removing the velocity of the center of mass - call vcm_vel(vcm) - if(me.eq.king.or..not.out1file)then - write (iout,*) "vcm right after adjustment:" - write (iout,*) (vcm(j),j=1,3) - endif - if (.not.rest) then - call chainbuild - if(iranconf.ne.0) then - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if(me.eq.king.or..not.out1file) & - write(iout,*) 'SC_move',nft_sc,etot - endif - - if(dccart)then - print *, 'Calling MINIM_DC' - call minim_dc(etot,iretcode,nfun) - else - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - endif - if(me.eq.king.or..not.out1file) & - write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - endif - endif - call chainbuild_cart - call kinetic(EK) - if (tbf) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK - if(me.eq.king.or..not.out1file)then - call cartprint - call intout - endif -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0=tcpu() -#endif - call zerograd - call etotal(potEcomp) - if (large) call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_etotal=t_etotal+MPI_Wtime()-tt0 -#else - t_etotal=t_etotal+tcpu()-tt0 -#endif -#endif - potE=potEcomp(0) - call cartgrad - call lagrangian - call max_accel - if (amax*d_time .gt. dvmax) then - d_time=d_time*dvmax/amax - if(me.eq.king.or..not.out1file) write (iout,*) & - "Time step reduced to",d_time,& - " because of too large initial acceleration." - endif - if(me.eq.king.or..not.out1file)then - write(iout,*) "Potential energy and its components" - call enerprint(potEcomp) -! write(iout,*) (potEcomp(i),i=0,n_ene) - endif - potE=potEcomp(0)-potEcomp(20) - totE=EK+potE - itime=0 - if (ntwe.ne.0) call statout(itime) - if(me.eq.king.or..not.out1file) & - write (iout,'(/a/3(a25,1pe14.5/))') "Initial:", & - " Kinetic energy",EK," Potential energy",potE, & - " Total energy",totE," Maximum acceleration ", & - amax - if (large) then - write (iout,*) "Initial coordinates" - do i=1,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3),& - (c(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),& - (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial velocities" - write (iout,"(13x,' backbone ',23x,' side chain')") - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),& - (d_t(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial accelerations" - do i=0,nres -! write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo -! write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) - enddo - if (RESPA) then -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_short(energia_short) - if (large) call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_eshort=t_eshort+MPI_Wtime()-tt0 -#else - t_eshort=t_eshort+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0),& - " energia_short",energia_short(0),& - " total",energia_long(0)+energia_short(0) - write (iout,*) "Initial fast-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - endif -! 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0=tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if (large) call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_elong=t_elong+MPI_Wtime()-tt0 -#else - t_elong=t_elong+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Initial slow-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),& - (d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - endif - return - end subroutine init_MD -!----------------------------------------------------------------------------- - subroutine random_vel - -! implicit real*8 (a-h,o-z) - use energy_data - use random, only:anorm_distr -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8) :: xv,sigv,lowb,highb ,Ek1 - integer :: i,j,ii,k,ind -! Generate random velocities from Gaussian distribution of mean 0 and std of KT/m -! First generate velocities in the eigenspace of the G matrix -! write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 -! call flush(iout) - xv=0.0d0 - ii=0 - do i=1,dimen - do k=1,3 - ii=ii+1 - sigv=dsqrt((Rb*t_bath)/geigen(i)) - lowb=-5*sigv - highb=5*sigv - d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) -! write (iout,*) "i",i," ii",ii," geigen",geigen(i),& -! " d_t_work_new",d_t_work_new(ii) - enddo - enddo -! diagnostics -! Ek1=0.0d0 -! ii=0 -! do i=1,dimen -! do k=1,3 -! ii=ii+1 -! Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 -! enddo -! enddo -! write (iout,*) "Ek from eigenvectors",Ek1 -! end diagnostics -! Transform velocities to UNRES coordinate space - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_t_work(ind)=0.0d0 - do j=1,dimen - d_t_work(ind)=d_t_work(ind) & - +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) - enddo -! write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) -! call flush(iout) - enddo - enddo -! Transfer to the d_t vector - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_t(j,i)=d_t_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - d_t(j,i+nres)=d_t_work(ind) - enddo - endif - enddo -! call kinetic(EK) -! write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature",& -! 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 -! call flush(iout) - return - end subroutine random_vel -!----------------------------------------------------------------------------- -#ifndef LANG0 - subroutine sd_verlet_p_setup -! Sets up the parameters of stochastic Verlet algorithm -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use control, only: tcpu - use control_data -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8),dimension(6*nres) :: emgdt !(MAXRES6) maxres6=6*maxres - real(kind=8) :: pterm,vterm,rho,rhoc,vsig - real(kind=8),dimension(6*nres) :: pfric_vec,vfric_vec,afric_vec,& - prand_vec,vrand_vec1,vrand_vec2 !(MAXRES6) maxres6=6*maxres - logical :: lprn = .false. - real(kind=8) :: zero = 1.0d-8, gdt_radius = 0.05d0 - real(kind=8) :: ktm,gdt,egdt,gdt2,gdt3,gdt4,gdt5,gdt6,gdt7,gdt8,& - gdt9,psig,tt0 - integer :: i,maxres2 -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -! -! AL 8/17/04 Code adapted from tinker -! -! Get the frictional and random terms for stochastic dynamics in the -! eigenspace of mass-scaled UNRES friction matrix -! - maxres2=2*nres - do i = 1, dimen - gdt = fricgam(i) * d_time -! -! Stochastic dynamics reduces to simple MD for zero friction -! - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0 * d_time * d_time - prand_vec(i) = 0.0d0 - vrand_vec1(i) = 0.0d0 - vrand_vec2(i) = 0.0d0 -! -! Analytical expressions when friction coefficient is large -! - else - if (gdt .ge. gdt_radius) then - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = (1.0d0-egdt) / fricgam(i) - afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) - pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt - vterm = 1.0d0 - egdt**2 - rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) -! -! Use series expansions when friction coefficient is small -! - else - gdt2 = gdt * gdt - gdt3 = gdt * gdt2 - gdt4 = gdt2 * gdt2 - gdt5 = gdt2 * gdt3 - gdt6 = gdt3 * gdt3 - gdt7 = gdt3 * gdt4 - gdt8 = gdt4 * gdt4 - gdt9 = gdt4 * gdt5 - afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 & - - gdt5/120.0d0 + gdt6/720.0d0 & - - gdt7/5040.0d0 + gdt8/40320.0d0 & - - gdt9/362880.0d0) / fricgam(i)**2 - vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) - pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) - pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 & - + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 & - + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 & - + 127.0d0*gdt9/90720.0d0 - vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 & - - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 & - - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 & - - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 - rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 & - - 17.0d0*gdt2/1280.0d0 & - + 17.0d0*gdt3/6144.0d0 & - + 40967.0d0*gdt4/34406400.0d0 & - - 57203.0d0*gdt5/275251200.0d0 & - - 1429487.0d0*gdt6/13212057600.0d0) - end if -! -! Compute the scaling factors of random terms for the nonzero friction case -! - ktm = 0.5d0*d_time/fricgam(i) - psig = dsqrt(ktm*pterm) / fricgam(i) - vsig = dsqrt(ktm*vterm) - rhoc = dsqrt(1.0d0 - rho*rho) - prand_vec(i) = psig - vrand_vec1(i) = vsig * rho - vrand_vec2(i) = vsig * rhoc - end if - end do - if (lprn) then - write (iout,*) & - "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",& - " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),& - afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -! -! Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -! -#ifndef LANG0 - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#endif -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end subroutine sd_verlet_p_setup -!----------------------------------------------------------------------------- - subroutine eigtransf1(n,ndim,ab,d,c) - -!el implicit none - integer :: n,ndim - real(kind=8) :: ab(ndim,ndim,n),c(ndim,n),d(ndim) - integer :: i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+ab(k,j,i)*d(k) - enddo - enddo - enddo - return - end subroutine eigtransf1 -!----------------------------------------------------------------------------- - subroutine eigtransf(n,ndim,a,b,d,c) - -!el implicit none - integer :: n,ndim - real(kind=8) :: a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) - integer :: i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) - enddo - enddo - enddo - return - end subroutine eigtransf -!----------------------------------------------------------------------------- - subroutine sd_verlet1 - -! Applying stochastic velocity Verlet algorithm - step 1 to velocities - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec - logical :: lprn = .false. - real(kind=8) :: ddt1,ddt2 - integer :: i,j,ind,inres - -! write (iout,*) "dc_old" -! do i=0,nres -! write (iout,'(i5,3f10.5,5x,3f10.5)') -! & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -! enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo -#ifndef LANG0 - if (lprn) then - write (iout,*) & - "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",& - " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),& - vfric_mat(i,j),afric_mat(i,j),& - prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) & - +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end subroutine sd_verlet1 -!----------------------------------------------------------------------------- - subroutine sd_verlet2 - -! Calculating the adjusted velocities for accelerations - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -!el real(kind=8),dimension(6*nres) :: stochforcvec,stochforcvecV !(MAXRES6) maxres6=6*maxres - real(kind=8),dimension(6*nres) :: stochforcvecV !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec -! - real(kind=8) :: ddt1,ddt2 - integer :: i,j,ind,inres -! Compute the stochastic forces which contribute to velocity change -! - call stochastic_force(stochforcvecV) - -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) - ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ & - vrand_mat2(i,j)*stochforcvecV(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end subroutine sd_verlet2 -!----------------------------------------------------------------------------- - subroutine sd_verlet_ciccotti_setup - -! Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's -! version -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use control, only: tcpu - use control_data -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8),dimension(6*nres) :: emgdt !(MAXRES6) maxres6=6*maxres - real(kind=8) :: pterm,vterm,rho,rhoc,vsig - real(kind=8),dimension(6*nres) :: pfric_vec,vfric_vec,afric_vec,& - prand_vec,vrand_vec1,vrand_vec2 !(MAXRES6) maxres6=6*maxres - logical :: lprn = .false. - real(kind=8) :: zero = 1.0d-8, gdt_radius = 0.05d0 - real(kind=8) :: ktm,gdt,egdt,tt0 - integer :: i,maxres2 -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -! -! AL 8/17/04 Code adapted from tinker -! -! Get the frictional and random terms for stochastic dynamics in the -! eigenspace of mass-scaled UNRES friction matrix -! - maxres2=2*nres - do i = 1, dimen - write (iout,*) "i",i," fricgam",fricgam(i) - gdt = fricgam(i) * d_time -! -! Stochastic dynamics reduces to simple MD for zero friction -! - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -! -! Analytical expressions when friction coefficient is large -! - else - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = dexp(-0.5d0*gdt)*d_time - afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -! -! Compute the scaling factors of random terms for the nonzero friction case -! -! ktm = 0.5d0*d_time/fricgam(i) -! psig = dsqrt(ktm*pterm) / fricgam(i) -! vsig = dsqrt(ktm*vterm) -! prand_vec(i) = psig*afric_vec(i) -! vrand_vec2(i) = vsig*vfric_vec(i) - end if - end do - if (lprn) then - write (iout,*) & - "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",& - " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),& - afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -! -! Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -! - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end subroutine sd_verlet_ciccotti_setup -!----------------------------------------------------------------------------- - subroutine sd_verlet1_ciccotti - -! Applying stochastic velocity Verlet algorithm - step 1 to velocities -! implicit real*8 (a-h,o-z) - use energy_data -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -!el real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec - logical :: lprn = .false. - real(kind=8) :: ddt1,ddt2 - integer :: i,j,ind,inres -! write (iout,*) "dc_old" -! do i=0,nres -! write (iout,'(i5,3f10.5,5x,3f10.5)') -! & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -! enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo - -#ifndef LANG0 - if (lprn) then - write (iout,*) & - "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",& - " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),& - vfric_mat(i,j),afric_mat(i,j),& - prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) & - +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end subroutine sd_verlet1_ciccotti -!----------------------------------------------------------------------------- - subroutine sd_verlet2_ciccotti - -! Calculating the adjusted velocities for accelerations - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -!el real(kind=8),dimension(6*nres) :: stochforcvec,stochforcvecV !(MAXRES6) maxres6=6*maxres - real(kind=8),dimension(6*nres) :: stochforcvecV !(MAXRES6) maxres6=6*maxres -!el common /stochcalc/ stochforcvec - real(kind=8) :: ddt1,ddt2 - integer :: i,j,ind,inres -! -! Compute the stochastic forces which contribute to velocity change -! - call stochastic_force(stochforcvecV) -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) -! ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) - ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end subroutine sd_verlet2_ciccotti -#endif -!----------------------------------------------------------------------------- -! moments.f -!----------------------------------------------------------------------------- - subroutine inertia_tensor - -! Calculating the intertia tensor for the entire protein in order to -! remove the perpendicular components of velocity matrix which cause -! the molecule to rotate. - use comm_gucio - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - - real(kind=8),dimension(3,3) :: Im,Imcp,eigvec,Id - real(kind=8),dimension(3) :: pr,eigval,L,vp,vrot - real(kind=8) :: M_SC,mag,mag2 - real(kind=8),dimension(3,0:nres) :: vpp !(3,0:MAXRES) - real(kind=8),dimension(3) :: vs_p,pp,incr,v - real(kind=8),dimension(3,3) :: pr1,pr2 - -!el common /gucio/ cm - integer :: iti,inres,i,j,k - do i=1,3 - do j=1,3 - Im(i,j)=0.0d0 - pr1(i,j)=0.0d0 - pr2(i,j)=0.0d0 - enddo - L(i)=0.0d0 - cm(i)=0.0d0 - vrot(i)=0.0d0 - enddo -! calculating the center of the mass of the protein - do i=nnt,nct-1 - do j=1,3 - cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) - enddo - enddo - do j=1,3 - cm(j)=mp*cm(j) - enddo - M_SC=0.0d0 - do i=nnt,nct - iti=iabs(itype(i)) - M_SC=M_SC+msc(iabs(iti)) - inres=i+nres - do j=1,3 - cm(j)=cm(j)+msc(iabs(iti))*c(j,inres) - enddo - enddo - do j=1,3 - cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) - enddo - - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) - Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) - Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) - Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct - iti=iabs(itype(i)) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - Im(1,1)=Im(1,1)+msc(iabs(iti))*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-msc(iabs(iti))*pr(1)*pr(2) - Im(1,3)=Im(1,3)-msc(iabs(iti))*pr(1)*pr(3) - Im(2,3)=Im(2,3)-msc(iabs(iti))*pr(2)*pr(3) - Im(2,2)=Im(2,2)+msc(iabs(iti))*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+msc(iabs(iti))*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct-1 - Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* & - vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* & - vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* & - vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* & - vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* & - vbld(i+1)*vbld(i+1)*0.25d0 - Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* & - vbld(i+1)*vbld(i+1)*0.25d0 - enddo - - - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - iti=iabs(itype(i)) - inres=i+nres - Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* & - dc_norm(1,inres))*vbld(inres)*vbld(inres) - Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* & - dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* & - dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* & - dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* & - dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* & - dc_norm(3,inres))*vbld(inres)*vbld(inres) - endif - enddo - - call angmom(cm,L) -! write(iout,*) "The angular momentum before adjustment:" -! write(iout,*) (L(j),j=1,3) - - Im(2,1)=Im(1,2) - Im(3,1)=Im(1,3) - Im(3,2)=Im(2,3) - -! Copying the Im matrix for the djacob subroutine - do i=1,3 - do j=1,3 - Imcp(i,j)=Im(i,j) - Id(i,j)=0.0d0 - enddo - enddo - -! Finding the eigenvectors and eignvalues of the inertia tensor - call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) -! write (iout,*) "Eigenvalues & Eigenvectors" -! write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) -! write (iout,*) -! do i=1,3 -! write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) -! enddo -! Constructing the diagonalized matrix - do i=1,3 - if (dabs(eigval(i)).gt.1.0d-15) then - Id(i,i)=1.0d0/eigval(i) - else - Id(i,i)=0.0d0 - endif - enddo - do i=1,3 - do j=1,3 - Imcp(i,j)=eigvec(j,i) - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) - enddo - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) - enddo - enddo - enddo -! Calculating the total rotational velocity of the molecule - do i=1,3 - do j=1,3 - vrot(i)=vrot(i)+pr2(i,j)*L(j) - enddo - enddo -! Resetting the velocities - do i=nnt,nct-1 - call vecpr(vrot(1),dc(1,i),vp) - do j=1,3 - d_t(j,i)=d_t(j,i)-vp(j) - enddo - enddo - do i=nnt,nct - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - call vecpr(vrot(1),dc(1,inres),vp) - do j=1,3 - d_t(j,inres)=d_t(j,inres)-vp(j) - enddo - endif - enddo - call angmom(cm,L) -! write(iout,*) "The angular momentum after adjustment:" -! write(iout,*) (L(j),j=1,3) - - return - end subroutine inertia_tensor -!----------------------------------------------------------------------------- - subroutine angmom(cm,L) - - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - - real(kind=8),dimension(3) :: L,cm,pr,vp,vrot,incr,v,pp - integer :: iti,inres,i,j -! Calculate the angular momentum - do j=1,3 - L(j)=0.0d0 - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - call vecpr(pr(1),v(1),vp) - do j=1,3 - L(j)=L(j)+mp*vp(j) - enddo - do j=1,3 - pr(j)=0.5d0*dc(j,i) - pp(j)=0.5d0*d_t(j,i) - enddo - call vecpr(pr(1),pp(1),vp) - do j=1,3 - L(j)=L(j)+Ip*vp(j) - enddo - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=iabs(itype(i)) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - else - do j=1,3 - v(j)=incr(j) - enddo - endif - call vecpr(pr(1),v(1),vp) -! write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), -! & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) - do j=1,3 - L(j)=L(j)+msc(iabs(iti))*vp(j) - enddo -! write (iout,*) "L",(l(j),j=1,3) - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - call vecpr(dc(1,inres),d_t(1,inres),vp) - do j=1,3 - L(j)=L(j)+Isc(iti)*vp(j) - enddo - endif - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo - return - end subroutine angmom -!----------------------------------------------------------------------------- - subroutine vcm_vel(vcm) - - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' - real(kind=8),dimension(3) :: vcm,vv - real(kind=8) :: summas,amas - integer :: i,j - - do j=1,3 - vcm(j)=0.0d0 - vv(j)=d_t(j,0) - enddo - summas=0.0d0 - do i=nnt,nct - if (i.lt.nct) then - summas=summas+mp - do j=1,3 - vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) - enddo - endif - amas=msc(iabs(itype(i))) - summas=summas+amas - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) - enddo - else - do j=1,3 - vcm(j)=vcm(j)+amas*vv(j) - enddo - endif - do j=1,3 - vv(j)=vv(j)+d_t(j,i) - enddo - enddo -! write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas - do j=1,3 - vcm(j)=vcm(j)/summas - enddo - return - end subroutine vcm_vel -!----------------------------------------------------------------------------- -! rattle.F -!----------------------------------------------------------------------------- - subroutine rattle1 -! RATTLE algorithm for velocity Verlet - step 1, UNRES -! AL 9/24/04 - use comm_przech - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef RATTLE -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -!el real(kind=8) :: gginv(2*nres,2*nres),& -!el gdc(3,2*nres,2*nres) - real(kind=8) :: dC_uncor(3,2*nres) !,& -!el real(kind=8) :: Cmat(2*nres,2*nres) - real(kind=8) :: x(2*nres),xcorr(3,2*nres) !maxres2=2*maxres -!el common /przechowalnia/ GGinv,gdc,Cmat,nbond -!el common /przechowalnia/ nbond - integer :: max_rattle = 5 - logical :: lprn = .false., lprn1 = .false., not_done - real(kind=8) :: tol_rattle = 1.0d-5 - - integer :: ii,i,j,jj,l,ind,ind1,nres2 - nres2=2*nres - -!el /common/ przechowalnia - - if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2)) - if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2)) - if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2)) -!el-------- - if (lprn) write (iout,*) "RATTLE1" - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -! Make a folded form of the Ginv-matrix - ind=0 - ii=0 - do i=nnt,nct-1 - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - endif - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - endif - enddo - enddo - endif - enddo - if (lprn1) then - write (iout,*) "Matrix GGinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) - endif - not_done=.true. - iter=0 - do while (not_done) - iter=iter+1 - if (iter.gt.max_rattle) then - write (iout,*) "Error - too many iterations in RATTLE." - stop - endif -! Calculate the matrix C = GG**(-1) dC_old o dC - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i+nres) - enddo - endif - enddo - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) - enddo - endif - enddo - enddo -! Calculate deviations from standard virtual-bond lengths - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=vbld(i+1)**2-vbl**2 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - endif - enddo - if (lprn) then - write (iout,*) "Coordinates and violations" - do i=1,nbond - write(iout,'(i5,3f10.5,5x,e15.5)') & - i,(dC_uncor(j,i),j=1,3),x(i) - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i+nres,ind,(d_t_new(j,i+nres),j=1,3),& - scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo -! write (iout,*) "gdc" -! do i=1,nbond -! write (iout,*) "i",i -! do j=1,nbond -! write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) -! enddo -! enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif -! Calculate the matrix of the system of equations - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,3 - Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -! Add constraint term to positions - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=0.5d0*xx - dC(j,i)=dC(j,i)-xx - d_t_new(j,i)=d_t_new(j,i)-xx/d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=0.5d0*xx - dC(j,i+nres)=dC(j,i+nres)-xx - d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time - enddo - endif - enddo -! Rebuild the chain using the new coordinates - call chainbuild_cart - if (lprn) then - write (iout,*) "New coordinates, Lagrange multipliers,",& - " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)**2-vbl**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i),j=1,3),x(ind),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i+nres),j=1,3),x(ind),xx - endif - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i+nres,ind,(d_t_new(j,i+nres),j=1,3),& - scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo - endif - enddo - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system",& - " of equations for Lagrange multipliers." - stop -#else - write (iout,*) & - "RATTLE inactive; use -DRATTLE switch at compile time." - stop -#endif - end subroutine rattle1 -!----------------------------------------------------------------------------- - subroutine rattle2 -! RATTLE algorithm for velocity Verlet - step 2, UNRES -! AL 9/24/04 - use comm_przech - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef RATTLE -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -!el real(kind=8) :: gginv(2*nres,2*nres),& -!el gdc(3,2*nres,2*nres) - real(kind=8) :: dC_uncor(3,2*nres) !,& -!el Cmat(2*nres,2*nres) - real(kind=8) :: x(2*nres) !maxres2=2*maxres -!el common /przechowalnia/ GGinv,gdc,Cmat,nbond -!el common /przechowalnia/ nbond - integer :: max_rattle = 5 - logical :: lprn = .false., lprn1 = .false., not_done - real(kind=8) :: tol_rattle = 1.0d-5 - integer :: nres2 - nres2=2*nres - -!el /common/ przechowalnia - if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2)) - if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2)) - if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2)) -!el-------- - if (lprn) write (iout,*) "RATTLE2" - if (lprn) write (iout,*) "Velocity correction" -! Calculate the matrix G dC - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres) - enddo - endif - enddo - enddo -! if (lprn) then -! write (iout,*) "gdc" -! do i=1,nbond -! write (iout,*) "i",i -! do j=1,nbond -! write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) -! enddo -! enddo -! endif -! Calculate the matrix of the system of equations - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,nbond - Cmat(ind,j)=0.0d0 - do k=1,3 - Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j) - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,nbond - Cmat(ind,j)=0.0d0 - do k=1,3 - Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j) - enddo - enddo - endif - enddo -! Calculate the scalar product dC o d_t_new - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=scalar(d_t(1,i),dC(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres)) - endif - enddo - if (lprn) then - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i,ind,(d_t(j,i),j=1,3),x(ind) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind) - endif - enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -! Add constraint term to velocities - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - d_t(j,i)=d_t(j,i)-xx - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - d_t(j,i+nres)=d_t(j,i+nres)-xx - enddo - endif - enddo - if (lprn) then - write (iout,*) & - "New velocities, Lagrange multipliers violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)') & - i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,2e15.5)') & - i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind),& - scalar(d_t(1,i+nres),dC(1,i+nres)) - endif - enddo - endif - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system",& - " of equations for Lagrange multipliers." - stop -#else - write (iout,*) & - "RATTLE inactive; use -DRATTLE option at compile time." - stop -#endif - end subroutine rattle2 -!----------------------------------------------------------------------------- - subroutine rattle_brown -! RATTLE/LINCS algorithm for Brownian dynamics, UNRES -! AL 9/24/04 - use comm_przech - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef RATTLE -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -!el real(kind=8) :: gginv(2*nres,2*nres),& -!el gdc(3,2*nres,2*nres) - real(kind=8) :: dC_uncor(3,2*nres) !,& -!el real(kind=8) :: Cmat(2*nres,2*nres) - real(kind=8) :: x(2*nres) !maxres2=2*maxres -!el common /przechowalnia/ GGinv,gdc,Cmat,nbond -!el common /przechowalnia/ nbond - integer :: max_rattle = 5 - logical :: lprn = .true., lprn1 = .true., not_done - real(kind=8) :: tol_rattle = 1.0d-5 - integer :: nres2 - nres2=2*nres - -!el /common/ przechowalnia - if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2)) - if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2)) - if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2)) -!el-------- - - if (lprn) write (iout,*) "RATTLE_BROWN" - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -! Make a folded form of the Ginv-matrix - ind=0 - ii=0 - do i=nnt,nct-1 - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - endif - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1) - enddo - endif - enddo - enddo - endif - enddo - if (lprn1) then - write (iout,*) "Matrix GGinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) - endif - not_done=.true. - iter=0 - do while (not_done) - iter=iter+1 - if (iter.gt.max_rattle) then - write (iout,*) "Error - too many iterations in RATTLE." - stop - endif -! Calculate the matrix C = GG**(-1) dC_old o dC - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i+nres) - enddo - endif - enddo - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) - enddo - endif - enddo - enddo -! Calculate deviations from standard virtual-bond lengths - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=vbld(i+1)**2-vbl**2 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - endif - enddo - if (lprn) then - write (iout,*) "Coordinates and violations" - do i=1,nbond - write(iout,'(i5,3f10.5,5x,e15.5)') & - i,(dC_uncor(j,i),j=1,3),x(i) - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i+nres,ind,(d_t(j,i+nres),j=1,3),& - scalar(d_t(1,i+nres),dC_old(1,i+nres)) - endif - enddo - write (iout,*) "gdc" - do i=1,nbond - write (iout,*) "i",i - do j=1,nbond - write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) - enddo - enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif -! Calculate the matrix of the system of equations - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,3 - Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -! Add constraint term to positions - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=-0.5d0*xx - d_t(j,i)=d_t(j,i)+xx/d_time - dC(j,i)=dC(j,i)+xx - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=-0.5d0*xx - d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time - dC(j,i+nres)=dC(j,i+nres)+xx - enddo - endif - enddo -! Rebuild the chain using the new coordinates - call chainbuild_cart - if (lprn) then - write (iout,*) "New coordinates, Lagrange multipliers,",& - " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)**2-vbl**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i),j=1,3),x(ind),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') & - i,(dC(j,i+nres),j=1,3),x(ind),xx - endif - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') & - i+nres,ind,(d_t_new(j,i+nres),j=1,3),& - scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo - endif - enddo - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system",& - " of equations for Lagrange multipliers." - stop -#else - write (iout,*) & - "RATTLE inactive; use -DRATTLE option at compile time" - stop -#endif - end subroutine rattle_brown -!----------------------------------------------------------------------------- -! stochfric.F -!----------------------------------------------------------------------------- - subroutine friction_force - - use energy_data - use REMD_data - use comm_syfek -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.IOUNITS' -!el real(kind=8),dimension(6*nres) :: gamvec !(MAXRES6) maxres6=6*maxres -!el common /syfek/ gamvec - real(kind=8) :: vv(3),vvtot(3,nres),v_work(6*nres) !,& -!el ginvfric(2*nres,2*nres) !maxres2=2*maxres -!el common /przechowalnia/ ginvfric - - logical :: lprn = .false., checkmode = .false. - integer :: i,j,ind,k,nres2,nres6 - nres2=2*nres - nres6=6*nres - - if(.not.allocated(gamvec)) allocate(gamvec(nres6)) !(MAXRES6) - if(.not.allocated(ginvfric)) allocate(ginvfric(nres2,nres2)) !maxres2=2*maxres - do i=0,nres2 - do j=1,3 - friction(j,i)=0.0d0 - enddo - enddo - - do j=1,3 - d_t_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t_work(ind+j)=d_t(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - d_t_work(ind+j)=d_t(j,i+nres) - enddo - ind=ind+3 - endif - enddo - - call fricmat_mult(d_t_work,fric_work) - - if (.not.checkmode) return - - if (lprn) then - write (iout,*) "d_t_work and fric_work" - do i=1,3*dimen - write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i) - enddo - endif - do j=1,3 - friction(j,0)=fric_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - friction(j,i)=fric_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - friction(j,i+nres)=fric_work(ind+j) - enddo - ind=ind+3 - endif - enddo - if (lprn) then - write(iout,*) "Friction backbone" - do i=0,nct-1 - write(iout,'(i5,3e15.5,5x,3e15.5)') & - i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3) - enddo - write(iout,*) "Friction side chain" - do i=nnt,nct - write(iout,'(i5,3e15.5,5x,3e15.5)') & - i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3) - enddo - endif - if (lprn) then - do j=1,3 - vv(j)=d_t(j,0) - enddo - do i=nnt,nct - do j=1,3 - vvtot(j,i)=vv(j)+0.5d0*d_t(j,i) - vvtot(j,i+nres)=vv(j)+d_t(j,i+nres) - vv(j)=vv(j)+d_t(j,i) - enddo - enddo - write (iout,*) "vvtot backbone and sidechain" - do i=nnt,nct - write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3),& - (vvtot(j,i+nres),j=1,3) - enddo - ind=0 - do i=nnt,nct-1 - do j=1,3 - v_work(ind+j)=vvtot(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - v_work(ind+j)=vvtot(j,i+nres) - enddo - ind=ind+3 - enddo - write (iout,*) "v_work gamvec and site-based friction forces" - do i=1,dimen1 - write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i),& - gamvec(i)*v_work(i) - enddo -! do i=1,dimen -! fric_work1(i)=0.0d0 -! do j=1,dimen1 -! fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j) -! enddo -! enddo -! write (iout,*) "fric_work and fric_work1" -! do i=1,dimen -! write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i) -! enddo - do i=1,dimen - do j=1,dimen - ginvfric(i,j)=0.0d0 - do k=1,dimen - ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j) - enddo - enddo - enddo - write (iout,*) "ginvfric" - do i=1,dimen - write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen) - enddo - write (iout,*) "symmetry check" - do i=1,dimen - do j=1,i-1 - write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i) - enddo - enddo - endif - return - end subroutine friction_force -!----------------------------------------------------------------------------- - subroutine setup_fricmat - -! use MPI - use energy_data - use control_data, only:time_Bcast - use control, only:tcpu - use comm_syfek -! implicit real*8 (a-h,o-z) -#ifdef MPI - use MPI_data - include 'mpif.h' - real(kind=8) :: time00 -#endif -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -! include 'COMMON.SETUP' -! include 'COMMON.TIME1' -! integer licznik /0/ -! save licznik -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.IOUNITS' - integer :: IERROR - integer :: i,j,ind,ind1,m - logical :: lprn = .false. - real(kind=8) :: dtdi !el ,gamvec(2*nres) -!el real(kind=8),dimension(2*nres,2*nres) :: ginvfric,fcopy - real(kind=8),dimension(2*nres,2*nres) :: fcopy -!el real(kind=8),dimension(2*nres*(2*nres+1)/2) :: Ghalf !(mmaxres2) (mmaxres2=(maxres2*(maxres2+1)/2)) -!el common /syfek/ gamvec - real(kind=8) :: work(8*2*nres) - integer :: iwork(2*nres) -!el common /przechowalnia/ ginvfric,Ghalf,fcopy - integer :: ii,iti,k,l,nzero,nres2,nres6,ierr -#ifdef MPI - if (fg_rank.ne.king) goto 10 -#endif - nres2=2*nres - nres6=6*nres - - if(.not.allocated(gamvec)) allocate(gamvec(nres2)) !(MAXRES2) - if(.not.allocated(ginvfric)) allocate(ginvfric(nres2,nres2)) !maxres2=2*maxres -!el if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2)) !maxres2=2*maxres -!el allocate(fcopy(nres2,nres2)) !maxres2=2*maxres - if(.not.allocated(Ghalf)) allocate(Ghalf(nres2*(nres2+1)/2)) !maxres2=2*maxres - -!el if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) -! Zeroing out fricmat - do i=1,dimen - do j=1,dimen - fricmat(i,j)=0.0d0 - enddo - enddo -! Load the friction coefficients corresponding to peptide groups - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - gamvec(ind1)=gamp - enddo -! Load the friction coefficients corresponding to side chains - m=nct-nnt - ind=0 - gamsc(ntyp1)=1.0d0 - do i=nnt,nct - ind=ind+1 - ii = ind+m - iti=itype(i) - gamvec(ii)=gamsc(iabs(iti)) - enddo - if (surfarea) call sdarea(gamvec) -! if (lprn) then -! write (iout,*) "Matrix A and vector gamma" -! do i=1,dimen1 -! write (iout,'(i2,$)') i -! do j=1,dimen -! write (iout,'(f4.1,$)') A(i,j) -! enddo -! write (iout,'(f8.3)') gamvec(i) -! enddo -! endif - if (lprn) then - write (iout,*) "Vector gamvec" - do i=1,dimen1 - write (iout,'(i5,f10.5)') i, gamvec(i) - enddo - endif - -! The friction matrix - do k=1,dimen - do i=1,dimen - dtdi=0.0d0 - do j=1,dimen1 - dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j) - enddo - fricmat(k,i)=dtdi - enddo - enddo - - if (lprn) then - write (iout,'(//a)') "Matrix fricmat" - call matout2(dimen,dimen,nres2,nres2,fricmat) - endif - if (lang.eq.2 .or. lang.eq.3) then -! Mass-scale the friction matrix if non-direct integration will be performed - do i=1,dimen - do j=1,dimen - Ginvfric(i,j)=0.0d0 - do k=1,dimen - do l=1,dimen - Ginvfric(i,j)=Ginvfric(i,j)+ & - Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l) - enddo - enddo - enddo - enddo -! Diagonalize the friction matrix - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=Ginvfric(i,j) - enddo - enddo - call gldiag(nres2,dimen,dimen,Ghalf,work,fricgam,fricvec,& - ierr,iwork) - if (lprn) then - write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",& - " mass-scaled friction matrix" - call eigout(dimen,dimen,nres2,nres2,fricvec,fricgam) - endif -! Precompute matrices for tinker stochastic integrator -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - mt1(i,j)=0.0d0 - mt2(i,j)=0.0d0 - do k=1,dimen - mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j) - mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j) - enddo - mt3(j,i)=mt1(i,j) - enddo - enddo -#endif - else if (lang.eq.4) then -! Diagonalize the friction matrix - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=fricmat(i,j) - enddo - enddo - call gldiag(nres2,dimen,dimen,Ghalf,work,fricgam,fricvec,& - ierr,iwork) - if (lprn) then - write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",& - " friction matrix" - call eigout(dimen,dimen,nres2,nres2,fricvec,fricgam) - endif -! Determine the number of zero eigenvalues of the friction matrix - nzero=max0(dimen-dimen1,0) -! do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen) -! nzero=nzero+1 -! enddo - write (iout,*) "Number of zero eigenvalues:",nzero - do i=1,dimen - do j=1,dimen - fricmat(i,j)=0.0d0 - do k=nzero+1,dimen - fricmat(i,j)=fricmat(i,j) & - +fricvec(i,k)*fricvec(j,k)/fricgam(k) - enddo - enddo - enddo - if (lprn) then - write (iout,'(//a)') "Generalized inverse of fricmat" - call matout(dimen,dimen,nres6,nres6,fricmat) - endif - endif -#ifdef MPI - 10 continue - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -! The matching BROADCAST for fg processors is called in ERGASTULUM -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif - call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR) -#ifdef MPI - time_Bcast=time_Bcast+MPI_Wtime()-time00 -#else - time_Bcast=time_Bcast+tcpu()-time00 -#endif -! print *,"Processor",myrank, -! & " BROADCAST iorder in SETUP_FRICMAT" - endif -! licznik=licznik+1 - write (iout,*) "setup_fricmat licznik"!,licznik !sp -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -! Scatter the friction matrix - call MPI_Scatterv(fricmat(1,1),nginv_counts(0),& - nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1),& - myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) -#ifdef TIMING -#ifdef MPI - time_scatter=time_scatter+MPI_Wtime()-time00 - time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00 -#else - time_scatter=time_scatter+tcpu()-time00 - time_scatter_fmat=time_scatter_fmat+tcpu()-time00 -#endif -#endif - do i=1,dimen - do j=1,2*my_ng_count - fricmat(j,i)=fcopy(i,j) - enddo - enddo -! write (iout,*) "My chunk of fricmat" -! call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) - endif -#endif - return - end subroutine setup_fricmat -!----------------------------------------------------------------------------- - subroutine stochastic_force(stochforcvec) - - use energy_data - use random, only:anorm_distr -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use control, only: tcpu - use control_data -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -! include 'COMMON.TIME1' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.IOUNITS' - - real(kind=8) :: x,sig,lowb,highb - real(kind=8) :: ff(3),force(3,0:2*nres),zeta2,lowb2 - real(kind=8) :: highb2,sig2,forcvec(6*nres),stochforcvec(6*nres) - real(kind=8) :: time00 - logical :: lprn = .false. - integer :: i,j,ind - - do i=0,2*nres - do j=1,3 - stochforc(j,i)=0.0d0 - enddo - enddo - x=0.0d0 - -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -! Compute the stochastic forces acting on bodies. Store in force. - do i=nnt,nct-1 - sig=stdforcp(i) - lowb=-5*sig - highb=5*sig - do j=1,3 - force(j,i)=anorm_distr(x,sig,lowb,highb) - enddo - enddo - do i=nnt,nct - sig2=stdforcsc(i) - lowb2=-5*sig2 - highb2=5*sig2 - do j=1,3 - force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) - enddo - enddo -#ifdef MPI - time_fsample=time_fsample+MPI_Wtime()-time00 -#else - time_fsample=time_fsample+tcpu()-time00 -#endif -! Compute the stochastic forces acting on virtual-bond vectors. - do j=1,3 - ff(j)=0.0d0 - enddo - do i=nct-1,nnt,-1 - do j=1,3 - stochforc(j,i)=ff(j)+0.5d0*force(j,i) - enddo - do j=1,3 - ff(j)=ff(j)+force(j,i) - enddo - if (itype(i+1).ne.ntyp1) then - do j=1,3 - stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1) - ff(j)=ff(j)+force(j,i+nres+1) - enddo - endif - enddo - do j=1,3 - stochforc(j,0)=ff(j)+force(j,nnt+nres) - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - stochforc(j,i+nres)=force(j,i+nres) - enddo - endif - enddo - - do j=1,3 - stochforcvec(j)=stochforc(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - stochforcvec(ind+j)=stochforc(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - stochforcvec(ind+j)=stochforc(j,i+nres) - enddo - ind=ind+3 - endif - enddo - if (lprn) then - write (iout,*) "stochforcvec" - do i=1,3*dimen - write(iout,'(i5,e15.5)') i,stochforcvec(i) - enddo - write(iout,*) "Stochastic forces backbone" - do i=0,nct-1 - write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3) - enddo - write(iout,*) "Stochastic forces side chain" - do i=nnt,nct - write(iout,'(i5,3e15.5)') & - i,(stochforc(j,i+nres),j=1,3) - enddo - endif - - if (lprn) then - - ind=0 - do i=nnt,nct-1 - write (iout,*) i,ind - do j=1,3 - forcvec(ind+j)=force(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - write (iout,*) i,ind - do j=1,3 - forcvec(j+ind)=force(j,i+nres) - enddo - ind=ind+3 - enddo - - write (iout,*) "forcvec" - ind=0 - do i=nnt,nct-1 - do j=1,3 - write (iout,'(2i3,2f10.5)') i,j,force(j,i),& - forcvec(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres),& - forcvec(ind+j) - enddo - ind=ind+3 - enddo - - endif - - return - end subroutine stochastic_force -!----------------------------------------------------------------------------- - subroutine sdarea(gamvec) -! -! Scale the friction coefficients according to solvent accessible surface areas -! Code adapted from TINKER -! AL 9/3/04 -! - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - real(kind=8),dimension(2*nres) :: radius,gamvec !(maxres2) - real(kind=8),parameter :: twosix = 1.122462048309372981d0 - logical :: lprn = .false. - real(kind=8) :: probe,area,ratio - integer :: i,j,ind,iti -! -! determine new friction coefficients every few SD steps -! -! set the atomic radii to estimates of sigma values -! -! print *,"Entered sdarea" - probe = 0.0d0 - - do i=1,2*nres - radius(i)=0.0d0 - enddo -! Load peptide group radii - do i=nnt,nct-1 - radius(i)=pstok - enddo -! Load side chain radii - do i=nnt,nct - iti=itype(i) - radius(i+nres)=restok(iti) - enddo -! do i=1,2*nres -! write (iout,*) "i",i," radius",radius(i) -! enddo - do i = 1, 2*nres - radius(i) = radius(i) / twosix - if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe - end do -! -! scale atomic friction coefficients by accessible area -! - if (lprn) write (iout,*) & - "Original gammas, surface areas, scaling factors, new gammas, ",& - "std's of stochastic forces" - ind=0 - do i=nnt,nct-1 - if (radius(i).gt.0.0d0) then - call surfatom (i,area,radius) - ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1) - if (lprn) write (iout,'(i5,3f10.5,$)') & - i,gamvec(ind+1),area,ratio - do j=1,3 - ind=ind+1 - gamvec(ind) = ratio * gamvec(ind) - enddo - stdforcp(i)=stdfp*dsqrt(gamvec(ind)) - if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i) - endif - enddo - do i=nnt,nct - if (radius(i+nres).gt.0.0d0) then - call surfatom (i+nres,area,radius) - ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1) - if (lprn) write (iout,'(i5,3f10.5,$)') & - i,gamvec(ind+1),area,ratio - do j=1,3 - ind=ind+1 - gamvec(ind) = ratio * gamvec(ind) - enddo - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind)) - if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i) - endif - enddo - - return - end subroutine sdarea -!----------------------------------------------------------------------------- -! surfatom.f -!----------------------------------------------------------------------------- -! -! -! ################################################### -! ## COPYRIGHT (C) 1996 by Jay William Ponder ## -! ## All Rights Reserved ## -! ################################################### -! -! ################################################################ -! ## ## -! ## subroutine surfatom -- exposed surface area of an atom ## -! ## ## -! ################################################################ -! -! -! "surfatom" performs an analytical computation of the surface -! area of a specified atom; a simplified version of "surface" -! -! literature references: -! -! T. J. Richmond, "Solvent Accessible Surface Area and -! Excluded Volume in Proteins", Journal of Molecular Biology, -! 178, 63-89 (1984) -! -! L. Wesson and D. Eisenberg, "Atomic Solvation Parameters -! Applied to Molecular Dynamics of Proteins in Solution", -! Protein Science, 1, 227-235 (1992) -! -! variables and parameters: -! -! ir number of atom for which area is desired -! area accessible surface area of the atom -! radius radii of each of the individual atoms -! -! - subroutine surfatom(ir,area,radius) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'sizes.i' -! include 'COMMON.GEO' -! include 'COMMON.IOUNITS' -! integer :: nres, - integer :: nsup,nstart_sup -! double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm -! common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), -! & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), -! & dc_work(MAXRES6),nres,nres0 - integer,parameter :: maxarc=300 - integer :: i,j,k,m - integer :: ii,ib,jb - integer :: io,ir - integer :: mi,ni,narc - integer :: key(maxarc) - integer :: intag(maxarc) - integer :: intag1(maxarc) - real(kind=8) :: area,arcsum - real(kind=8) :: arclen,exang - real(kind=8) :: delta,delta2 - real(kind=8) :: eps,rmove - real(kind=8) :: xr,yr,zr - real(kind=8) :: rr,rrsq - real(kind=8) :: rplus,rminus - real(kind=8) :: axx,axy,axz - real(kind=8) :: ayx,ayy - real(kind=8) :: azx,azy,azz - real(kind=8) :: uxj,uyj,uzj - real(kind=8) :: tx,ty,tz - real(kind=8) :: txb,tyb,td - real(kind=8) :: tr2,tr,txr,tyr - real(kind=8) :: tk1,tk2 - real(kind=8) :: thec,the,t,tb - real(kind=8) :: txk,tyk,tzk - real(kind=8) :: t1,ti,tf,tt - real(kind=8) :: txj,tyj,tzj - real(kind=8) :: ccsq,cc,xysq - real(kind=8) :: bsqk,bk,cosine - real(kind=8) :: dsqj,gi,pix2 - real(kind=8) :: therk,dk,gk - real(kind=8) :: risqk,rik - real(kind=8) :: radius(2*nres) !(maxatm) (maxatm=maxres2) - real(kind=8) :: ri(maxarc),risq(maxarc) - real(kind=8) :: ux(maxarc),uy(maxarc),uz(maxarc) - real(kind=8) :: xc(maxarc),yc(maxarc),zc(maxarc) - real(kind=8) :: xc1(maxarc),yc1(maxarc),zc1(maxarc) - real(kind=8) :: dsq(maxarc),bsq(maxarc) - real(kind=8) :: dsq1(maxarc),bsq1(maxarc) - real(kind=8) :: arci(maxarc),arcf(maxarc) - real(kind=8) :: ex(maxarc),lt(maxarc),gr(maxarc) - real(kind=8) :: b(maxarc),b1(maxarc),bg(maxarc) - real(kind=8) :: kent(maxarc),kout(maxarc) - real(kind=8) :: ther(maxarc) - logical :: moved,top - logical :: omit(maxarc) -! -! include 'sizes.i' - maxatm = 2*nres !maxres2 maxres2=2*maxres - maxlight = 8*maxatm - maxbnd = 2*maxatm - maxang = 3*maxatm - maxtors = 4*maxatm -! -! zero out the surface area for the sphere of interest -! - area = 0.0d0 -! write (2,*) "ir",ir," radius",radius(ir) - if (radius(ir) .eq. 0.0d0) return -! -! set the overlap significance and connectivity shift -! - pix2 = 2.0d0 * pi - delta = 1.0d-8 - delta2 = delta * delta - eps = 1.0d-8 - moved = .false. - rmove = 1.0d-8 -! -! store coordinates and radius of the sphere of interest -! - xr = c(1,ir) - yr = c(2,ir) - zr = c(3,ir) - rr = radius(ir) - rrsq = rr * rr -! -! initialize values of some counters and summations -! - 10 continue - io = 0 - jb = 0 - ib = 0 - arclen = 0.0d0 - exang = 0.0d0 -! -! test each sphere to see if it overlaps the sphere of interest -! - do i = 1, 2*nres - if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 - rplus = rr + radius(i) - tx = c(1,i) - xr - if (abs(tx) .ge. rplus) goto 30 - ty = c(2,i) - yr - if (abs(ty) .ge. rplus) goto 30 - tz = c(3,i) - zr - if (abs(tz) .ge. rplus) goto 30 -! -! check for sphere overlap by testing distance against radii -! - xysq = tx*tx + ty*ty - if (xysq .lt. delta2) then - tx = delta - ty = 0.0d0 - xysq = delta2 - end if - ccsq = xysq + tz*tz - cc = sqrt(ccsq) - if (rplus-cc .le. delta) goto 30 - rminus = rr - radius(i) -! -! check to see if sphere of interest is completely buried -! - if (cc-abs(rminus) .le. delta) then - if (rminus .le. 0.0d0) goto 170 - goto 30 - end if -! -! check for too many overlaps with sphere of interest -! - if (io .ge. maxarc) then - write (iout,20) - 20 format (/,' SURFATOM -- Increase the Value of MAXARC') - stop - end if -! -! get overlap between current sphere and sphere of interest -! - io = io + 1 - xc1(io) = tx - yc1(io) = ty - zc1(io) = tz - dsq1(io) = xysq - bsq1(io) = ccsq - b1(io) = cc - gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) - intag1(io) = i - omit(io) = .false. - 30 continue - end do -! -! case where no other spheres overlap the sphere of interest -! - if (io .eq. 0) then - area = 4.0d0 * pi * rrsq - return - end if -! -! case where only one sphere overlaps the sphere of interest -! - if (io .eq. 1) then - area = pix2 * (1.0d0 + gr(1)) - area = mod(area,4.0d0*pi) * rrsq - return - end if -! -! case where many spheres intersect the sphere of interest; -! sort the intersecting spheres by their degree of overlap -! - call sort2 (io,gr,key) - do i = 1, io - k = key(i) - intag(i) = intag1(k) - xc(i) = xc1(k) - yc(i) = yc1(k) - zc(i) = zc1(k) - dsq(i) = dsq1(k) - b(i) = b1(k) - bsq(i) = bsq1(k) - end do -! -! get radius of each overlap circle on surface of the sphere -! - do i = 1, io - gi = gr(i) * rr - bg(i) = b(i) * gi - risq(i) = rrsq - gi*gi - ri(i) = sqrt(risq(i)) - ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) - end do -! -! find boundary of inaccessible area on sphere of interest -! - do k = 1, io-1 - if (.not. omit(k)) then - txk = xc(k) - tyk = yc(k) - tzk = zc(k) - bk = b(k) - therk = ther(k) -! -! check to see if J circle is intersecting K circle; -! get distance between circle centers and sum of radii -! - do j = k+1, io - if (omit(j)) goto 60 - cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) - cc = acos(min(1.0d0,max(-1.0d0,cc))) - td = therk + ther(j) -! -! check to see if circles enclose separate regions -! - if (cc .ge. td) goto 60 -! -! check for circle J completely inside circle K -! - if (cc+ther(j) .lt. therk) goto 40 -! -! check for circles that are essentially parallel -! - if (cc .gt. delta) goto 50 - 40 continue - omit(j) = .true. - goto 60 -! -! check to see if sphere of interest is completely buried -! - 50 continue - if (pix2-cc .le. td) goto 170 - 60 continue - end do - end if - end do -! -! find T value of circle intersections -! - do k = 1, io - if (omit(k)) goto 110 - omit(k) = .true. - narc = 0 - top = .false. - txk = xc(k) - tyk = yc(k) - tzk = zc(k) - dk = sqrt(dsq(k)) - bsqk = bsq(k) - bk = b(k) - gk = gr(k) * rr - risqk = risq(k) - rik = ri(k) - therk = ther(k) -! -! rotation matrix elements -! - t1 = tzk / (bk*dk) - axx = txk * t1 - axy = tyk * t1 - axz = dk / bk - ayx = tyk / dk - ayy = txk / dk - azx = txk / bk - azy = tyk / bk - azz = tzk / bk - do j = 1, io - if (.not. omit(j)) then - txj = xc(j) - tyj = yc(j) - tzj = zc(j) -! -! rotate spheres so K vector colinear with z-axis -! - uxj = txj*axx + tyj*axy - tzj*axz - uyj = tyj*ayy - txj*ayx - uzj = txj*azx + tyj*azy + tzj*azz - cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) - if (acos(cosine) .lt. therk+ther(j)) then - dsqj = uxj*uxj + uyj*uyj - tb = uzj*gk - bg(j) - txb = uxj * tb - tyb = uyj * tb - td = rik * dsqj - tr2 = risqk*dsqj - tb*tb - tr2 = max(eps,tr2) - tr = sqrt(tr2) - txr = uxj * tr - tyr = uyj * tr -! -! get T values of intersection for K circle -! - tb = (txb+tyr) / td - tb = min(1.0d0,max(-1.0d0,tb)) - tk1 = acos(tb) - if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 - tb = (txb-tyr) / td - tb = min(1.0d0,max(-1.0d0,tb)) - tk2 = acos(tb) - if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 - thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) - if (abs(thec) .lt. 1.0d0) then - the = -acos(thec) - else if (thec .ge. 1.0d0) then - the = 0.0d0 - else if (thec .le. -1.0d0) then - the = -pi - end if -! -! see if "tk1" is entry or exit point; check t=0 point; -! "ti" is exit point, "tf" is entry point -! - cosine = min(1.0d0,max(-1.0d0, & - (uzj*gk-uxj*rik)/(b(j)*rr))) - if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then - ti = tk2 - tf = tk1 - else - ti = tk2 - tf = tk1 - end if - narc = narc + 1 - if (narc .ge. maxarc) then - write (iout,70) - 70 format (/,' SURFATOM -- Increase the Value',& - ' of MAXARC') - stop - end if - if (tf .le. ti) then - arcf(narc) = tf - arci(narc) = 0.0d0 - tf = pix2 - lt(narc) = j - ex(narc) = the - top = .true. - narc = narc + 1 - end if - arcf(narc) = tf - arci(narc) = ti - lt(narc) = j - ex(narc) = the - ux(j) = uxj - uy(j) = uyj - uz(j) = uzj - end if - end if - end do - omit(k) = .false. -! -! special case; K circle without intersections -! - if (narc .le. 0) goto 90 -! -! general case; sum up arclength and set connectivity code -! - call sort2 (narc,arci,key) - arcsum = arci(1) - mi = key(1) - t = arcf(mi) - ni = mi - if (narc .gt. 1) then - do j = 2, narc - m = key(j) - if (t .lt. arci(j)) then - arcsum = arcsum + arci(j) - t - exang = exang + ex(ni) - jb = jb + 1 - if (jb .ge. maxarc) then - write (iout,80) - 80 format (/,' SURFATOM -- Increase the Value',& - ' of MAXARC') - stop - end if - i = lt(ni) - kent(jb) = maxarc*i + k - i = lt(m) - kout(jb) = maxarc*k + i - end if - tt = arcf(m) - if (tt .ge. t) then - t = tt - ni = m - end if - end do - end if - arcsum = arcsum + pix2 - t - if (.not. top) then - exang = exang + ex(ni) - jb = jb + 1 - i = lt(ni) - kent(jb) = maxarc*i + k - i = lt(mi) - kout(jb) = maxarc*k + i - end if - goto 100 - 90 continue - arcsum = pix2 - ib = ib + 1 - 100 continue - arclen = arclen + gr(k)*arcsum - 110 continue - end do - if (arclen .eq. 0.0d0) goto 170 - if (jb .eq. 0) goto 150 -! -! find number of independent boundaries and check connectivity -! - j = 0 - do k = 1, jb - if (kout(k) .ne. 0) then - i = k - 120 continue - m = kout(i) - kout(i) = 0 - j = j + 1 - do ii = 1, jb - if (m .eq. kent(ii)) then - if (ii .eq. k) then - ib = ib + 1 - if (j .eq. jb) goto 150 - goto 130 - end if - i = ii - goto 120 - end if - end do - 130 continue - end if - end do - ib = ib + 1 -! -! attempt to fix connectivity error by moving atom slightly -! - if (moved) then - write (iout,140) ir - 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6) - else - moved = .true. - xr = xr + rmove - yr = yr + rmove - zr = zr + rmove - goto 10 - end if -! -! compute the exposed surface area for the sphere of interest -! - 150 continue - area = ib*pix2 + exang + arclen - area = mod(area,4.0d0*pi) * rrsq -! -! attempt to fix negative area by moving atom slightly -! - if (area .lt. 0.0d0) then - if (moved) then - write (iout,160) ir - 160 format (/,' SURFATOM -- Negative Area at Atom',i6) - else - moved = .true. - xr = xr + rmove - yr = yr + rmove - zr = zr + rmove - goto 10 - end if - end if - 170 continue - return - end subroutine surfatom -!---------------------------------------------------------------- -!---------------------------------------------------------------- - subroutine alloc_MD_arrays -!EL Allocation of arrays used by MD module - - integer :: nres2,nres6 - nres2=nres*2 - nres6=nres*6 -!---------------------- -#ifndef LANG0 -! commom.langevin -! common /langforc/ - allocate(friction(3,0:nres2),stochforc(3,0:nres2)) !(3,0:MAXRES2) - allocate(fric_work(nres6),stoch_work(nres6),fricgam(nres6)) !(MAXRES6) - if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) - allocate(fricvec(nres2,nres2)) - allocate(pfric_mat(nres2,nres2),vfric_mat(nres2,nres2)) - allocate(afric_mat(nres2,nres2),prand_mat(nres2,nres2)) - allocate(vrand_mat1(nres2,nres2),vrand_mat2(nres2,nres2)) !(MAXRES2,MAXRES2) - allocate(pfric0_mat(nres2,nres2,0:maxflag_stoch)) - allocate(afric0_mat(nres2,nres2,0:maxflag_stoch)) - allocate(vfric0_mat(nres2,nres2,0:maxflag_stoch)) - allocate(prand0_mat(nres2,nres2,0:maxflag_stoch)) - allocate(vrand0_mat1(nres2,nres2,0:maxflag_stoch)) - allocate(vrand0_mat2(nres2,nres2,0:maxflag_stoch)) !(MAXRES2,MAXRES2,0:maxflag_stoch) - allocate(flag_stoch(0:maxflag_stoch)) !(0:maxflag_stoch) -! common /langmat/ - allocate(mt1(nres2,nres2),mt2(nres2,nres2),mt3(nres2,nres2)) !(maxres2,maxres2) -!---------------------- -#else -! commom.langevin.lang0 -! common /langforc/ - allocate(friction(3,0:nres2),stochforc(3,0:nres2)) !(3,0:MAXRES2) - if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) - allocate(fricvec(nres2,nres2)) !(MAXRES2,MAXRES2) - allocate(fric_work(nres6),stoch_work(nres6),fricgam(nres6)) !(MAXRES6) - allocate(flag_stoch(0:maxflag_stoch)) !(0:maxflag_stoch) -#endif - -!el if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2)) -!---------------------- -! commom.hairpin in CSA module -!---------------------- -! common.mce in MCM_MD module -!---------------------- -! common.MD -! common /mdgrad/ in module.energy -! common /back_constr/ in module.energy -! common /qmeas/ in module.energy -! common /mdpar/ -! common /MDcalc/ - allocate(potEcomp(0:n_ene+4)) !(0:n_ene+4) -! common /lagrange/ - allocate(d_t(3,0:nres2),d_a(3,0:nres2),d_t_old(3,0:nres2)) !(3,0:MAXRES2) - allocate(d_a_work(nres6)) !(6*MAXRES) - allocate(Gmat(nres2,nres2),A(nres2,nres2)) - if(.not.allocated(Ginv)) allocate(Ginv(nres2,nres2)) !in control: ergastulum - allocate(Gsqrp(nres2,nres2),Gsqrm(nres2,nres2),Gvec(nres2,nres2)) !(maxres2,maxres2) - allocate(Geigen(nres2)) !(maxres2) - if(.not.allocated(vtot)) allocate(vtot(nres2)) !(maxres2) -! common /inertia/ in io_conf: parmread -! real(kind=8),dimension(:),allocatable :: ISC,msc !(ntyp+1) -! common /langevin/in io read_MDpar -! real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1) -! real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp) -! in io_conf: parmread -! real(kind=8),dimension(:),allocatable :: restok !(ntyp+1) -! common /mdpmpi/ in control: ergastulum - if(.not.allocated(ng_start)) allocate(ng_start(0:nfgtasks-1)) - if(.not.allocated(ng_counts)) allocate(ng_counts(0:nfgtasks-1)) - if(.not.allocated(nginv_counts)) allocate(nginv_counts(0:nfgtasks-1)) !(0:MaxProcs-1) - if(.not.allocated(nginv_start)) allocate(nginv_start(0:nfgtasks)) !(0:MaxProcs) -!---------------------- -! common.muca in read_muca -! common /double_muca/ -! real(kind=8) :: elow,ehigh,factor,hbin,factor_min -! real(kind=8),dimension(:),allocatable :: emuca,nemuca,& -! nemuca2,hist !(4*maxres) -! common /integer_muca/ -! integer :: nmuca,imtime,muca_smooth -! common /mucarem/ -! real(kind=8),dimension(:),allocatable :: elowi,ehighi !(maxprocs) -!---------------------- -! common.MD -! common /mdgrad/ in module.energy -! common /back_constr/ in module.energy -! common /qmeas/ in module.energy -! common /mdpar/ -! common /MDcalc/ -! common /lagrange/ - allocate(d_t_work(nres6),d_t_work_new(nres6),d_af_work(nres6)) - allocate(d_as_work(nres6),kinetic_force(nres6)) !(MAXRES6) - allocate(d_t_new(3,0:nres2),d_a_old(3,0:nres2),d_a_short(3,0:nres2)) !,d_a !(3,0:MAXRES2) - allocate(stdforcp(nres),stdforcsc(nres)) !(MAXRES) -!---------------------- -! COMMON /BANII/ D - allocate(D_ban(nres6)) !(MAXRES6) maxres6=6*maxres -! common /stochcalc/ stochforcvec - allocate(stochforcvec(nres6)) !(MAXRES6) maxres6=6*maxres -!---------------------- - return - end subroutine alloc_MD_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module MDyn diff --git a/source/unres/MPI.F90 b/source/unres/MPI.F90 new file mode 100644 index 0000000..f88297d --- /dev/null +++ b/source/unres/MPI.F90 @@ -0,0 +1,594 @@ + module MPI_ +!----------------------------------------------------------------------------- + use io_units + use MPI_data + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! MP.F +!----------------------------------------------------------------------------- +#ifdef MPI + subroutine init_task + + use control, only: initialize,getenv_loc + use io_config, only: openunits + use control_data, only: out1file + include 'mpif.h' +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' + logical :: lprn=.false. +! real*8 text1 /'group_i '/,text2/'group_f '/, +! & text3/'initialb'/,text4/'initiale'/, +! & text5/'openb'/,text6/'opene'/ + integer,dimension(0:max_cg_procs) :: cgtasks !(0:max_cg_procs) + character(len=3) :: cfgprocs + integer :: cg_size,fg_size,fg_size1 +!el local variables + integer :: i,ierr,key + real(kind=8) :: world_group,cg_group + + allocate(status(MPI_STATUS_SIZE)) + +! start parallel processing + print *,'Initializing MPI' + print *,'MPI_STATUS_SIZE',MPI_STATUS_SIZE + call mpi_init(ierr) + write(2, *) "ierr",ierr + call flush(iout) + if (ierr.ne.0) then + print *, ' cannot initialize MPI' + stop + endif +! determine # of nodes and current node + call MPI_COMM_RANK( MPI_COMM_WORLD, me, ierr ) + if (ierr.ne.0) then + print *, ' cannot determine rank of all processes' + call MPI_Finalize( MPI_COMM_WORLD, IERR ) + stop + endif + call MPI_Comm_size( MPI_Comm_world, nodes, ierr ) + if (ierr.ne.0) then + print *, ' cannot determine number of processes' + stop + endif + Nprocs=nodes + MyRank=me +! Determine the number of "fine-grain" tasks + print *,"Before getenv FGPROCS" + call getenv_loc("FGPROCS",cfgprocs) + print *,cfgprocs + read (cfgprocs,'(i3)') nfgtasks + if (nfgtasks.eq.0) nfgtasks=1 + print *,nfgtasks + print *,"Before getenv MAXFGPROCS" + call getenv_loc("MAXGSPROCS",cfgprocs) + print *,cfgprocs + read (cfgprocs,'(i3)') max_gs_size + if (max_gs_size.eq.0) max_gs_size=2 + if (lprn) & + print *,"Processor",me," nfgtasks",nfgtasks,& + " max_gs_size",max_gs_size + if (nfgtasks.eq.1) then + CG_COMM = MPI_COMM_WORLD + fg_size=1 + fg_rank=0 + nfgtasks1=1 + fg_rank1=0 + else + nodes=nprocs/nfgtasks + if (nfgtasks*nodes.ne.nprocs) then + write (*,'(a)') 'ERROR: Number of processors assigned',& + ' to coarse-grained tasks must be divisor',& + ' of the total number of processors.' + call MPI_Finalize( MPI_COMM_WORLD, IERR ) + stop + endif +! Put the ranks of coarse-grain processes in one table and create +! the respective communicator. The processes with ranks "in between" +! the ranks of CG processes will perform fine graining for the CG +! process with the next lower rank. +!el allocate(cgtasks(0:nodes)) + do i=0,nprocs-1,nfgtasks + cgtasks(i/nfgtasks)=i + enddo + if (lprn) then + print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1) +! print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group" + endif +! call memmon_print_usage() + call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR) + call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR) + call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR) + call MPI_Group_rank(cg_group,me,ierr) + call MPI_Group_free(world_group,ierr) + call MPI_Group_free(cg_group,ierr) +! print "(a,i5,a)","Processor",myrank," After MPI_Comm_group" +! call memmon_print_usage() + if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr) + if (lprn) print *," Processor",myrank," CG rank",me +! Create communicators containig processes doing "fine grain" tasks. +! The processes within each FG_COMM should have fast communication. + kolor=MyRank/nfgtasks + key=mod(MyRank,nfgtasks) + call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr) + call MPI_Comm_size(FG_COMM,fg_size,ierr) + if (fg_size.ne.nfgtasks) then + write (*,*) "OOOOps... the number of fg tasks is",fg_size,& + " but",nfgtasks," was requested. MyRank=",MyRank + endif + call MPI_Comm_rank(FG_COMM,fg_rank,ierr) + if (fg_size.gt.max_gs_size) then + kolor1=fg_rank/max_gs_size + key1=mod(fg_rank,max_gs_size) + call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr) + call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr) + call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr) + else + FG_COMM1=FG_COMM + nfgtasks1=nfgtasks + fg_rank1=fg_rank + endif + endif + if (lprn) then + if (fg_rank.eq.0) then + write (*,*) "Processor",MyRank," out of",nprocs,& + " rank in CG_COMM",me," size of CG_COMM",nodes,& + " size of FG_COMM",fg_size,& + " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 + else + write (*,*) "Processor",MyRank," out of",nprocs,& + " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size,& + " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 + endif + endif +! Initialize other variables. +! print '(a)','Before initialize' +! call memmon_print_usage() + call initialize +! print '(a,i5,a)','Processor',myrank,' After initialize' +! call memmon_print_usage() +! Open task-dependent files. +! print '(a,i5,a)','Processor',myrank,' Before openunits' +! call memmon_print_usage() + call openunits +! print '(a,i5,a)','Processor',myrank,' After openunits' +! call memmon_print_usage() + if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file) & + write (iout,'(80(1h*)/a/80(1h*))') & + 'United-residue force field calculation - parallel job.' +! print *,"Processor",myrank," exited OPENUNITS" +!el deallocate(cgtasks) + return + end subroutine init_task +!----------------------------------------------------------------------------- + subroutine finish_task + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! use energy + use io_base, only:ilen,move_from_tmp + use MD_data, only: mdpdb,ntwe + use REMD_data, only: restart1file,traj1file + use control_data + include 'mpif.h' +! use MD +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.REMD' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.TIME1' +! include 'COMMON.MD' +!el integer ilen +!el external ilen +!el local variables + integer :: IERROR,ierr + real(kind=8) :: time1 +! + call MPI_Barrier(CG_COMM,ierr) + if (nfgtasks.gt.1) & + call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR) + time1=MPI_WTIME() +! if (me.eq.king .or. .not. out1file) then + write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.' + write (iout,*) 'Total wall clock time',time1-walltime,' sec' + if (nfgtasks.gt.1) then + write (iout,'(80(1h=)/a/(80(1h=)))') & + "Details of FG communication time" + write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') & + "BROADCAST:",time_bcast,"REDUCE:",time_reduce,& + "GATHER:",time_gather,& + "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,& + "BARRIER ene",time_barrier_e,& + "BARRIER grad",time_barrier_g,"TOTAL:",& + time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv & + +time_barrier_e+time_barrier_g + write (*,*) 'Total wall clock time',time1-walltime,' sec' + write (*,*) "Processor",me," BROADCAST time",time_bcast,& + " REDUCE time",& + time_reduce," GATHER time",time_gather," SCATTER time",& + time_scatter," SENDRECV",time_sendrecv,& + " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g + endif +! endif + write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.' + if (ilen(tmpdir).gt.0) then + write (*,*) "Processor",me,& + ": moving output files to the parent directory..." + close(inp) + close(istat,status='keep') + if (ntwe.gt.0) call move_from_tmp(statname) + close(irest2,status='keep') + if (modecalc.eq.12.or. & + (modecalc.eq.14 .and. .not.restart1file)) then + call move_from_tmp(rest2name) + else if (modecalc.eq.14.and. me.eq.king) then + call move_from_tmp(mremd_rst_name) + endif + if (mdpdb) then + close(ipdb,status='keep') + call move_from_tmp(pdbname) + else if (me.eq.king .or. .not.traj1file) then + close(icart,status='keep') + call move_from_tmp(cartname) + endif + if (me.eq.king .or. .not. out1file) then + close (iout,status='keep') + call move_from_tmp(outname) + endif + endif + return + end subroutine finish_task +!----------------------------------------------------------------------------- + subroutine pattern_receive + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use compare_data, only:nexcl,iexam + include 'mpif.h' +! include 'COMMON.SETUP' +! include 'COMMON.THREAD' +! include 'COMMON.IOUNITS' + integer :: tag,status(MPI_STATUS_SIZE) + integer :: source,ThreadType + logical :: flag + integer :: ierr,ireq,iproc + ThreadType=45 + source=mpi_any_source + call mpi_iprobe(source,ThreadType,& + CG_COMM,flag,status,ierr) + do while (flag) + write (iout,*) 'Processor ',Me,' is receiving threading',& + ' pattern from processor',status(mpi_source) + write (*,*) 'Processor ',Me,' is receiving threading',& + ' pattern from processor',status(mpi_source) + nexcl=nexcl+1 + call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source),& + ThreadType, CG_COMM,ireq,ierr) + write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl),& + iexam(2,nexcl) + source=mpi_any_source + call mpi_iprobe(source,ThreadType,& + CG_COMM,flag,status,ierr) + enddo + return + end subroutine pattern_receive +!----------------------------------------------------------------------------- + subroutine pattern_send + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use compare_data, only:nexcl,iexam + include 'mpif.h' +! include 'COMMON.INFO' +! include 'COMMON.THREAD' +! include 'COMMON.IOUNITS' + integer :: source,ThreadType,ireq,iproc,ierr + ThreadType=45 + do iproc=0,nprocs-1 + if (iproc.ne.me .and. .not.Koniec(iproc) ) then + call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc,& + ThreadType, CG_COMM, ireq, ierr) + write (iout,*) 'CG processor ',me,' has sent pattern ',& + 'to processor',iproc + write (*,*) 'CG processor ',me,' has sent pattern ',& + 'to processor',iproc + write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl) + endif + enddo + end subroutine pattern_send +!----------------------------------------------------------------------------- + subroutine send_stop_sig(Kwita) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.INFO' +! include 'COMMON.IOUNITS' + integer :: StopType,StopId,iproc,Kwita,NBytes + integer :: ierr + StopType=66 +! Kwita=-1 +! print *,'CG processor',me,' StopType=',StopType + Koniec(me)=.true. + if (me.eq.king) then +! Master sends the STOP signal to everybody. + write (iout,'(a,a)') & + 'Master is sending STOP signal to other processors.' + do iproc=1,nprocs-1 + print *,'Koniec(',iproc,')=',Koniec(iproc) + if (.not. Koniec(iproc)) then + call mpi_send(Kwita,1,mpi_integer,iproc,StopType,& + mpi_comm_world,ierr) + write (iout,*) 'Iproc=',iproc,' StopID=',StopID + write (*,*) 'Iproc=',iproc,' StopID=',StopID + endif + enddo + else +! Else send the STOP signal to Master. + call mpi_send(Kwita,1,mpi_integer,MasterID,StopType,& + mpi_comm_world,ierr) + write (iout,*) 'CG processor=',me,' StopID=',StopID + write (*,*) 'CG processor=',me,' StopID=',StopID + endif + return + end subroutine send_stop_sig +!----------------------------------------------------------------------------- + subroutine recv_stop_sig(Kwita) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.INFO' +! include 'COMMON.IOUNITS' + integer :: source,StopType,StopId,iproc,Kwita,ireq,ierr + logical :: flag + + StopType=66 + Kwita=0 + source=mpi_any_source + allocate(koniec(0:nprocs)) !(0:maxprocs-1) + +! print *,'CG processor:',me,' StopType=',StopType + call mpi_iprobe(source,StopType,& + mpi_comm_world,flag,status,ierr) + do while (flag) + Koniec(status(mpi_source))=.true. + write (iout,*) 'CG processor ',me,' is receiving STOP signal',& + ' from processor',status(mpi_source) + write (*,*) 'CG processor ',me,' is receiving STOP signal',& + ' from processor',status(mpi_source) + call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType,& + mpi_comm_world,ireq,ierr) + call mpi_iprobe(source,StopType,& + mpi_comm_world,flag,status,ierr) + enddo + return + end subroutine recv_stop_sig +!----------------------------------------------------------------------------- + subroutine send_MCM_info(ione) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.SETUP' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' + integer :: tag,status(MPI_STATUS_SIZE) + integer :: MCM_info_Type,MCM_info_ID,iproc,one,NBytes +!el common /aaaa/ isend,irecv + integer :: nsend,ione,ierr,isend,irecv + save nsend + nsend=nsend+1 + MCM_info_Type=77 +!cd write (iout,'(a,i4,a)') 'CG Processor',me, +!cd & ' is sending MCM info to Master.' + write (*,'(a,i4,a,i8)') 'CG processor',me,& + ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID + call mpi_isend(ione,1,mpi_integer,MasterID,& + MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr) +!cd write (iout,*) 'CG processor',me,' has sent info to the master;', +!cd & ' MCM_info_ID=',MCM_info_ID + write (*,*) 'CG processor',me,' has sent info to the master;',& + ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr + isend=0 + irecv=0 + return + end subroutine send_MCM_info +!----------------------------------------------------------------------------- + subroutine receive_MCM_info + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use names + use MCM_data, only:nacc_tot,nsave_part + use compare_data, only:nthread,nexcl,ipatt + include 'mpif.h' +! include 'COMMON.SETUP' +! include 'COMMON.MCM' +! include 'COMMON.IOUNITS' + integer :: tag,status(MPI_STATUS_SIZE) + integer :: source,MCM_info_Type,MCM_info_ID,iproc,ione + logical :: flag + integer :: itask,ierr + MCM_info_Type=77 + source=mpi_any_source +! print *,'source=',source,' dontcare=',dontcare + call mpi_iprobe(source,MCM_info_Type,& + mpi_comm_world,flag,status,ierr) + do while (flag) + source=status(mpi_source) + itask=source/fgProcs+1 +!d write (iout,*) 'Master is receiving MCM info from processor ',& +!d source,' itask',itask + write (*,*) 'Master is receiving MCM info from processor ',& + source,' itask',itask + call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type,& + mpi_comm_world,MCM_info_ID,ierr) +!d write (iout,*) 'Received from processor',source,' IONE=',ione + write (*,*) 'Received from processor',source,' IONE=',ione + nacc_tot=nacc_tot+1 + if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1 +!cd print *,'nsave_part(',itask,')=',nsave_part(itask) +!cd write (iout,*) 'Nacc_tot=',Nacc_tot +!cd write (*,*) 'Nacc_tot=',Nacc_tot + source=mpi_any_source + call mpi_iprobe(source,MCM_info_Type,& + mpi_comm_world,flag,status,ierr) + enddo + return + end subroutine receive_MCM_info +!----------------------------------------------------------------------------- + subroutine send_thread_results + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use names + use compare_data + include 'mpif.h' +! include 'COMMON.SETUP' +! include 'COMMON.THREAD' +! include 'COMMON.IOUNITS' + integer :: tag,status(MPI_STATUS_SIZE) + integer :: ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,& + EnerID,msglen,nbytes + real(kind=8) :: buffer(20*maxthread+2) + integer :: i,j,ierror + ThreadType=444 + EnerType=555 + ipatt(1,nthread+1)=nthread + ipatt(2,nthread+1)=nexcl + do i=1,nthread + do j=1,n_ene + ener(j,i+nthread)=ener0(j,i) + enddo + enddo + ener(1,2*nthread+1)=max_time_for_thread + ener(2,2*nthread+1)=ave_time_for_thread +! Send the IPATT array + write (iout,*) 'CG processor',me,& + ' is sending IPATT array to master: NTHREAD=',nthread + write (*,*) 'CG processor',me,& + ' is sending IPATT array to master: NTHREAD=',nthread + msglen=2*nthread+2 + call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID,& + ThreadType,mpi_comm_world,ierror) + write (iout,*) 'CG processor',me,& + ' has sent IPATT array to master MSGLEN',msglen + write (*,*) 'CG processor',me,& + ' has sent IPATT array to master MSGLEN',msglen +! Send the energies. + msglen=n_ene2*nthread+2 + write (iout,*) 'CG processor',me,' is sending energies to master.' + write (*,*) 'CG processor',me,' is sending energies to master.' + call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID,& + EnerType,mpi_comm_world,ierror) + write (iout,*) 'CG processor',me,' has sent energies to master.' + write (*,*) 'CG processor',me,' has sent energies to master.' + return + end subroutine send_thread_results +!----------------------------------------------------------------------------- + subroutine receive_thread_results(iproc) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use names + use compare_data + include 'mpif.h' +! include 'COMMON.INFO' +! include 'COMMON.THREAD' +! include 'COMMON.IOUNITS' + integer :: ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,& + EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp + real(kind=8) :: buffer(20*maxthread+2),max_time_for_thread_t,& + ave_time_for_thread_t + logical :: flag + integer :: iproc,ierr,ierror,i,j + real(kind=8) :: nexcl_temp + ThreadType=444 + EnerType=555 +! Receive the IPATT array + call mpi_probe(iproc,ThreadType,& + mpi_comm_world,status,ierr) + call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR) + write (iout,*) 'Master is receiving IPATT array from processor:',& + iproc,' MSGLEN',msglen + write (*,*) 'Master is receiving IPATT array from processor:',& + iproc,' MSGLEN',msglen + call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc,& + ThreadType,& + mpi_comm_world,status,ierror) + write (iout,*) 'Master has received IPATT array from processor:',& + iproc,' MSGLEN=',msglen + write (*,*) 'Master has received IPATT array from processor:',& + iproc,' MSGLEN=',msglen + nthread_temp=ipatt(1,nthread+msglen/2) + nexcl_temp=ipatt(2,nthread+msglen/2) +! Receive the energies. + call mpi_probe(iproc,EnerType,& + mpi_comm_world,status,ierr) + call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR) + write (iout,*) 'Master is receiving energies from processor:',& + iproc,' MSGLEN=',MSGLEN + write (*,*) 'Master is receiving energies from processor:',& + iproc,' MSGLEN=',MSGLEN + call mpi_recv(ener(1,nthread+1),msglen,& + MPI_DOUBLE_PRECISION,iproc,& + EnerType,MPI_COMM_WORLD,status,ierror) + write (iout,*) 'Msglen=',Msglen + write (*,*) 'Msglen=',Msglen + write (iout,*) 'Master has received energies from processor',iproc + write (*,*) 'Master has received energies from processor',iproc + write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp + write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp + do i=1,nthread_temp + do j=1,n_ene + ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i) + enddo + enddo + max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1) + ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1) + write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t + write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t + write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t + write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t + if (max_time_for_thread_t.gt.max_time_for_thread) & + max_time_for_thread=max_time_for_thread_t + ave_time_for_thread=(nthread*ave_time_for_thread+ & + nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp) + nthread=nthread+nthread_temp + return + end subroutine receive_thread_results +!----------------------------------------------------------------------------- +#else + subroutine init_task + + use control, only: initialize,getenv_loc + use io_config, only: openunits +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.SETUP' + integer :: fg_size + + me=0 + myrank=0 + fg_rank=0 + fg_size=1 + nodes=1 + nprocs=1 + call initialize + call openunits + write (iout,'(80(1h*)/a/80(1h*))') & + 'United-residue force field calculation - serial job.' + return + end subroutine init_task +#endif +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module MPI_ diff --git a/source/unres/MPI.f90 b/source/unres/MPI.f90 deleted file mode 100644 index f88297d..0000000 --- a/source/unres/MPI.f90 +++ /dev/null @@ -1,594 +0,0 @@ - module MPI_ -!----------------------------------------------------------------------------- - use io_units - use MPI_data - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! MP.F -!----------------------------------------------------------------------------- -#ifdef MPI - subroutine init_task - - use control, only: initialize,getenv_loc - use io_config, only: openunits - use control_data, only: out1file - include 'mpif.h' -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.IOUNITS' - logical :: lprn=.false. -! real*8 text1 /'group_i '/,text2/'group_f '/, -! & text3/'initialb'/,text4/'initiale'/, -! & text5/'openb'/,text6/'opene'/ - integer,dimension(0:max_cg_procs) :: cgtasks !(0:max_cg_procs) - character(len=3) :: cfgprocs - integer :: cg_size,fg_size,fg_size1 -!el local variables - integer :: i,ierr,key - real(kind=8) :: world_group,cg_group - - allocate(status(MPI_STATUS_SIZE)) - -! start parallel processing - print *,'Initializing MPI' - print *,'MPI_STATUS_SIZE',MPI_STATUS_SIZE - call mpi_init(ierr) - write(2, *) "ierr",ierr - call flush(iout) - if (ierr.ne.0) then - print *, ' cannot initialize MPI' - stop - endif -! determine # of nodes and current node - call MPI_COMM_RANK( MPI_COMM_WORLD, me, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine rank of all processes' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif - call MPI_Comm_size( MPI_Comm_world, nodes, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine number of processes' - stop - endif - Nprocs=nodes - MyRank=me -! Determine the number of "fine-grain" tasks - print *,"Before getenv FGPROCS" - call getenv_loc("FGPROCS",cfgprocs) - print *,cfgprocs - read (cfgprocs,'(i3)') nfgtasks - if (nfgtasks.eq.0) nfgtasks=1 - print *,nfgtasks - print *,"Before getenv MAXFGPROCS" - call getenv_loc("MAXGSPROCS",cfgprocs) - print *,cfgprocs - read (cfgprocs,'(i3)') max_gs_size - if (max_gs_size.eq.0) max_gs_size=2 - if (lprn) & - print *,"Processor",me," nfgtasks",nfgtasks,& - " max_gs_size",max_gs_size - if (nfgtasks.eq.1) then - CG_COMM = MPI_COMM_WORLD - fg_size=1 - fg_rank=0 - nfgtasks1=1 - fg_rank1=0 - else - nodes=nprocs/nfgtasks - if (nfgtasks*nodes.ne.nprocs) then - write (*,'(a)') 'ERROR: Number of processors assigned',& - ' to coarse-grained tasks must be divisor',& - ' of the total number of processors.' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif -! Put the ranks of coarse-grain processes in one table and create -! the respective communicator. The processes with ranks "in between" -! the ranks of CG processes will perform fine graining for the CG -! process with the next lower rank. -!el allocate(cgtasks(0:nodes)) - do i=0,nprocs-1,nfgtasks - cgtasks(i/nfgtasks)=i - enddo - if (lprn) then - print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1) -! print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group" - endif -! call memmon_print_usage() - call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR) - call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR) - call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR) - call MPI_Group_rank(cg_group,me,ierr) - call MPI_Group_free(world_group,ierr) - call MPI_Group_free(cg_group,ierr) -! print "(a,i5,a)","Processor",myrank," After MPI_Comm_group" -! call memmon_print_usage() - if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr) - if (lprn) print *," Processor",myrank," CG rank",me -! Create communicators containig processes doing "fine grain" tasks. -! The processes within each FG_COMM should have fast communication. - kolor=MyRank/nfgtasks - key=mod(MyRank,nfgtasks) - call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr) - call MPI_Comm_size(FG_COMM,fg_size,ierr) - if (fg_size.ne.nfgtasks) then - write (*,*) "OOOOps... the number of fg tasks is",fg_size,& - " but",nfgtasks," was requested. MyRank=",MyRank - endif - call MPI_Comm_rank(FG_COMM,fg_rank,ierr) - if (fg_size.gt.max_gs_size) then - kolor1=fg_rank/max_gs_size - key1=mod(fg_rank,max_gs_size) - call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr) - call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr) - call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr) - else - FG_COMM1=FG_COMM - nfgtasks1=nfgtasks - fg_rank1=fg_rank - endif - endif - if (lprn) then - if (fg_rank.eq.0) then - write (*,*) "Processor",MyRank," out of",nprocs,& - " rank in CG_COMM",me," size of CG_COMM",nodes,& - " size of FG_COMM",fg_size,& - " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - else - write (*,*) "Processor",MyRank," out of",nprocs,& - " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size,& - " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - endif - endif -! Initialize other variables. -! print '(a)','Before initialize' -! call memmon_print_usage() - call initialize -! print '(a,i5,a)','Processor',myrank,' After initialize' -! call memmon_print_usage() -! Open task-dependent files. -! print '(a,i5,a)','Processor',myrank,' Before openunits' -! call memmon_print_usage() - call openunits -! print '(a,i5,a)','Processor',myrank,' After openunits' -! call memmon_print_usage() - if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file) & - write (iout,'(80(1h*)/a/80(1h*))') & - 'United-residue force field calculation - parallel job.' -! print *,"Processor",myrank," exited OPENUNITS" -!el deallocate(cgtasks) - return - end subroutine init_task -!----------------------------------------------------------------------------- - subroutine finish_task - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! use energy - use io_base, only:ilen,move_from_tmp - use MD_data, only: mdpdb,ntwe - use REMD_data, only: restart1file,traj1file - use control_data - include 'mpif.h' -! use MD -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.REMD' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.TIME1' -! include 'COMMON.MD' -!el integer ilen -!el external ilen -!el local variables - integer :: IERROR,ierr - real(kind=8) :: time1 -! - call MPI_Barrier(CG_COMM,ierr) - if (nfgtasks.gt.1) & - call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR) - time1=MPI_WTIME() -! if (me.eq.king .or. .not. out1file) then - write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.' - write (iout,*) 'Total wall clock time',time1-walltime,' sec' - if (nfgtasks.gt.1) then - write (iout,'(80(1h=)/a/(80(1h=)))') & - "Details of FG communication time" - write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') & - "BROADCAST:",time_bcast,"REDUCE:",time_reduce,& - "GATHER:",time_gather,& - "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,& - "BARRIER ene",time_barrier_e,& - "BARRIER grad",time_barrier_g,"TOTAL:",& - time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv & - +time_barrier_e+time_barrier_g - write (*,*) 'Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",me," BROADCAST time",time_bcast,& - " REDUCE time",& - time_reduce," GATHER time",time_gather," SCATTER time",& - time_scatter," SENDRECV",time_sendrecv,& - " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g - endif -! endif - write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.' - if (ilen(tmpdir).gt.0) then - write (*,*) "Processor",me,& - ": moving output files to the parent directory..." - close(inp) - close(istat,status='keep') - if (ntwe.gt.0) call move_from_tmp(statname) - close(irest2,status='keep') - if (modecalc.eq.12.or. & - (modecalc.eq.14 .and. .not.restart1file)) then - call move_from_tmp(rest2name) - else if (modecalc.eq.14.and. me.eq.king) then - call move_from_tmp(mremd_rst_name) - endif - if (mdpdb) then - close(ipdb,status='keep') - call move_from_tmp(pdbname) - else if (me.eq.king .or. .not.traj1file) then - close(icart,status='keep') - call move_from_tmp(cartname) - endif - if (me.eq.king .or. .not. out1file) then - close (iout,status='keep') - call move_from_tmp(outname) - endif - endif - return - end subroutine finish_task -!----------------------------------------------------------------------------- - subroutine pattern_receive - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use compare_data, only:nexcl,iexam - include 'mpif.h' -! include 'COMMON.SETUP' -! include 'COMMON.THREAD' -! include 'COMMON.IOUNITS' - integer :: tag,status(MPI_STATUS_SIZE) - integer :: source,ThreadType - logical :: flag - integer :: ierr,ireq,iproc - ThreadType=45 - source=mpi_any_source - call mpi_iprobe(source,ThreadType,& - CG_COMM,flag,status,ierr) - do while (flag) - write (iout,*) 'Processor ',Me,' is receiving threading',& - ' pattern from processor',status(mpi_source) - write (*,*) 'Processor ',Me,' is receiving threading',& - ' pattern from processor',status(mpi_source) - nexcl=nexcl+1 - call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source),& - ThreadType, CG_COMM,ireq,ierr) - write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl),& - iexam(2,nexcl) - source=mpi_any_source - call mpi_iprobe(source,ThreadType,& - CG_COMM,flag,status,ierr) - enddo - return - end subroutine pattern_receive -!----------------------------------------------------------------------------- - subroutine pattern_send - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use compare_data, only:nexcl,iexam - include 'mpif.h' -! include 'COMMON.INFO' -! include 'COMMON.THREAD' -! include 'COMMON.IOUNITS' - integer :: source,ThreadType,ireq,iproc,ierr - ThreadType=45 - do iproc=0,nprocs-1 - if (iproc.ne.me .and. .not.Koniec(iproc) ) then - call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc,& - ThreadType, CG_COMM, ireq, ierr) - write (iout,*) 'CG processor ',me,' has sent pattern ',& - 'to processor',iproc - write (*,*) 'CG processor ',me,' has sent pattern ',& - 'to processor',iproc - write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl) - endif - enddo - end subroutine pattern_send -!----------------------------------------------------------------------------- - subroutine send_stop_sig(Kwita) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.INFO' -! include 'COMMON.IOUNITS' - integer :: StopType,StopId,iproc,Kwita,NBytes - integer :: ierr - StopType=66 -! Kwita=-1 -! print *,'CG processor',me,' StopType=',StopType - Koniec(me)=.true. - if (me.eq.king) then -! Master sends the STOP signal to everybody. - write (iout,'(a,a)') & - 'Master is sending STOP signal to other processors.' - do iproc=1,nprocs-1 - print *,'Koniec(',iproc,')=',Koniec(iproc) - if (.not. Koniec(iproc)) then - call mpi_send(Kwita,1,mpi_integer,iproc,StopType,& - mpi_comm_world,ierr) - write (iout,*) 'Iproc=',iproc,' StopID=',StopID - write (*,*) 'Iproc=',iproc,' StopID=',StopID - endif - enddo - else -! Else send the STOP signal to Master. - call mpi_send(Kwita,1,mpi_integer,MasterID,StopType,& - mpi_comm_world,ierr) - write (iout,*) 'CG processor=',me,' StopID=',StopID - write (*,*) 'CG processor=',me,' StopID=',StopID - endif - return - end subroutine send_stop_sig -!----------------------------------------------------------------------------- - subroutine recv_stop_sig(Kwita) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.INFO' -! include 'COMMON.IOUNITS' - integer :: source,StopType,StopId,iproc,Kwita,ireq,ierr - logical :: flag - - StopType=66 - Kwita=0 - source=mpi_any_source - allocate(koniec(0:nprocs)) !(0:maxprocs-1) - -! print *,'CG processor:',me,' StopType=',StopType - call mpi_iprobe(source,StopType,& - mpi_comm_world,flag,status,ierr) - do while (flag) - Koniec(status(mpi_source))=.true. - write (iout,*) 'CG processor ',me,' is receiving STOP signal',& - ' from processor',status(mpi_source) - write (*,*) 'CG processor ',me,' is receiving STOP signal',& - ' from processor',status(mpi_source) - call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType,& - mpi_comm_world,ireq,ierr) - call mpi_iprobe(source,StopType,& - mpi_comm_world,flag,status,ierr) - enddo - return - end subroutine recv_stop_sig -!----------------------------------------------------------------------------- - subroutine send_MCM_info(ione) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.SETUP' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' - integer :: tag,status(MPI_STATUS_SIZE) - integer :: MCM_info_Type,MCM_info_ID,iproc,one,NBytes -!el common /aaaa/ isend,irecv - integer :: nsend,ione,ierr,isend,irecv - save nsend - nsend=nsend+1 - MCM_info_Type=77 -!cd write (iout,'(a,i4,a)') 'CG Processor',me, -!cd & ' is sending MCM info to Master.' - write (*,'(a,i4,a,i8)') 'CG processor',me,& - ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID - call mpi_isend(ione,1,mpi_integer,MasterID,& - MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr) -!cd write (iout,*) 'CG processor',me,' has sent info to the master;', -!cd & ' MCM_info_ID=',MCM_info_ID - write (*,*) 'CG processor',me,' has sent info to the master;',& - ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr - isend=0 - irecv=0 - return - end subroutine send_MCM_info -!----------------------------------------------------------------------------- - subroutine receive_MCM_info - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use names - use MCM_data, only:nacc_tot,nsave_part - use compare_data, only:nthread,nexcl,ipatt - include 'mpif.h' -! include 'COMMON.SETUP' -! include 'COMMON.MCM' -! include 'COMMON.IOUNITS' - integer :: tag,status(MPI_STATUS_SIZE) - integer :: source,MCM_info_Type,MCM_info_ID,iproc,ione - logical :: flag - integer :: itask,ierr - MCM_info_Type=77 - source=mpi_any_source -! print *,'source=',source,' dontcare=',dontcare - call mpi_iprobe(source,MCM_info_Type,& - mpi_comm_world,flag,status,ierr) - do while (flag) - source=status(mpi_source) - itask=source/fgProcs+1 -!d write (iout,*) 'Master is receiving MCM info from processor ',& -!d source,' itask',itask - write (*,*) 'Master is receiving MCM info from processor ',& - source,' itask',itask - call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type,& - mpi_comm_world,MCM_info_ID,ierr) -!d write (iout,*) 'Received from processor',source,' IONE=',ione - write (*,*) 'Received from processor',source,' IONE=',ione - nacc_tot=nacc_tot+1 - if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1 -!cd print *,'nsave_part(',itask,')=',nsave_part(itask) -!cd write (iout,*) 'Nacc_tot=',Nacc_tot -!cd write (*,*) 'Nacc_tot=',Nacc_tot - source=mpi_any_source - call mpi_iprobe(source,MCM_info_Type,& - mpi_comm_world,flag,status,ierr) - enddo - return - end subroutine receive_MCM_info -!----------------------------------------------------------------------------- - subroutine send_thread_results - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use names - use compare_data - include 'mpif.h' -! include 'COMMON.SETUP' -! include 'COMMON.THREAD' -! include 'COMMON.IOUNITS' - integer :: tag,status(MPI_STATUS_SIZE) - integer :: ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,& - EnerID,msglen,nbytes - real(kind=8) :: buffer(20*maxthread+2) - integer :: i,j,ierror - ThreadType=444 - EnerType=555 - ipatt(1,nthread+1)=nthread - ipatt(2,nthread+1)=nexcl - do i=1,nthread - do j=1,n_ene - ener(j,i+nthread)=ener0(j,i) - enddo - enddo - ener(1,2*nthread+1)=max_time_for_thread - ener(2,2*nthread+1)=ave_time_for_thread -! Send the IPATT array - write (iout,*) 'CG processor',me,& - ' is sending IPATT array to master: NTHREAD=',nthread - write (*,*) 'CG processor',me,& - ' is sending IPATT array to master: NTHREAD=',nthread - msglen=2*nthread+2 - call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID,& - ThreadType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me,& - ' has sent IPATT array to master MSGLEN',msglen - write (*,*) 'CG processor',me,& - ' has sent IPATT array to master MSGLEN',msglen -! Send the energies. - msglen=n_ene2*nthread+2 - write (iout,*) 'CG processor',me,' is sending energies to master.' - write (*,*) 'CG processor',me,' is sending energies to master.' - call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID,& - EnerType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me,' has sent energies to master.' - write (*,*) 'CG processor',me,' has sent energies to master.' - return - end subroutine send_thread_results -!----------------------------------------------------------------------------- - subroutine receive_thread_results(iproc) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use names - use compare_data - include 'mpif.h' -! include 'COMMON.INFO' -! include 'COMMON.THREAD' -! include 'COMMON.IOUNITS' - integer :: ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,& - EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp - real(kind=8) :: buffer(20*maxthread+2),max_time_for_thread_t,& - ave_time_for_thread_t - logical :: flag - integer :: iproc,ierr,ierror,i,j - real(kind=8) :: nexcl_temp - ThreadType=444 - EnerType=555 -! Receive the IPATT array - call mpi_probe(iproc,ThreadType,& - mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR) - write (iout,*) 'Master is receiving IPATT array from processor:',& - iproc,' MSGLEN',msglen - write (*,*) 'Master is receiving IPATT array from processor:',& - iproc,' MSGLEN',msglen - call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc,& - ThreadType,& - mpi_comm_world,status,ierror) - write (iout,*) 'Master has received IPATT array from processor:',& - iproc,' MSGLEN=',msglen - write (*,*) 'Master has received IPATT array from processor:',& - iproc,' MSGLEN=',msglen - nthread_temp=ipatt(1,nthread+msglen/2) - nexcl_temp=ipatt(2,nthread+msglen/2) -! Receive the energies. - call mpi_probe(iproc,EnerType,& - mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR) - write (iout,*) 'Master is receiving energies from processor:',& - iproc,' MSGLEN=',MSGLEN - write (*,*) 'Master is receiving energies from processor:',& - iproc,' MSGLEN=',MSGLEN - call mpi_recv(ener(1,nthread+1),msglen,& - MPI_DOUBLE_PRECISION,iproc,& - EnerType,MPI_COMM_WORLD,status,ierror) - write (iout,*) 'Msglen=',Msglen - write (*,*) 'Msglen=',Msglen - write (iout,*) 'Master has received energies from processor',iproc - write (*,*) 'Master has received energies from processor',iproc - write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - do i=1,nthread_temp - do j=1,n_ene - ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i) - enddo - enddo - max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1) - ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1) - write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - if (max_time_for_thread_t.gt.max_time_for_thread) & - max_time_for_thread=max_time_for_thread_t - ave_time_for_thread=(nthread*ave_time_for_thread+ & - nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp) - nthread=nthread+nthread_temp - return - end subroutine receive_thread_results -!----------------------------------------------------------------------------- -#else - subroutine init_task - - use control, only: initialize,getenv_loc - use io_config, only: openunits -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.SETUP' - integer :: fg_size - - me=0 - myrank=0 - fg_rank=0 - fg_size=1 - nodes=1 - nprocs=1 - call initialize - call openunits - write (iout,'(80(1h*)/a/80(1h*))') & - 'United-residue force field calculation - serial job.' - return - end subroutine init_task -#endif -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module MPI_ diff --git a/source/unres/MREMD.F90 b/source/unres/MREMD.F90 new file mode 100644 index 0000000..92a1178 --- /dev/null +++ b/source/unres/MREMD.F90 @@ -0,0 +1,2024 @@ + module MREMDyn +!----------------------------------------------------------------------------- + use io_units + use names + use MPI_data + use md_data + use remd_data + use geometry_data + use energy_data + use control_data, only:maxprocs + use MDyn + + implicit none +!----------------------------------------------------------------------------- +! commom.remd +! common /remdrestart/ + integer(kind=2),dimension(:),allocatable :: i2set !(0:maxprocs) + integer(kind=2),dimension(:),allocatable :: ifirst !(maxprocs) + integer(kind=2),dimension(:,:),allocatable :: nupa,& + ndowna !(0:maxprocs/4,0:maxprocs) + real(kind=4),dimension(:,:),allocatable :: t_restart1 !(5,maxprocs) + integer,dimension(:),allocatable :: iset_restart1 !(maxprocs) +! common /traj1cache/ + real(kind=4),dimension(:),allocatable :: totT_cache,EK_cache,& + potE_cache,t_bath_cache,Uconst_cache !(max_cache_traj) + real(kind=4),dimension(:,:),allocatable :: qfrag_cache !(50,max_cache_traj) + real(kind=4),dimension(:,:),allocatable :: qpair_cache !(100,max_cache_traj) + real(kind=4),dimension(:,:),allocatable :: ugamma_cache,& + utheta_cache,uscdiff_cache !(maxfrag_back,max_cache_traj) + real(kind=4),dimension(:,:,:),allocatable :: c_cache !(3,maxres2+2,max_cache_traj) + integer :: ntwx_cache,ii_write !,max_cache_traj_use + integer,dimension(:),allocatable :: iset_cache !(max_cache_traj) +!----------------------------------------------------------------------------- +! common /przechowalnia/ + real(kind=4),dimension(:,:),allocatable :: d_restart1 !(3,2*nres*maxprocs) + real(kind=4),dimension(:,:),allocatable :: d_restart2 !(3,2*nres*maxprocs) + real(kind=4),dimension(:,:),allocatable :: p_c !(3,(nres2+2)*maxprocs) +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- +! MREMD.F +!----------------------------------------------------------------------------- + + subroutine MREMD + + use comm_gucio + use control, only:tcpu,ovrtim + use io_base, only:ilen + use control_data + use geometry_data + use random, only: iran_num,ran_number + use compare, only:hairpin,secondary2 + use io, only:cartout,statout +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.MUCA' +! include 'COMMON.HAIRPIN' + integer :: ERRCODE + real(kind=8),dimension(3) :: L,vcm + real(kind=8) :: energia(0:n_ene) + real(kind=8) :: remd_t_bath(maxprocs) + integer :: iremd_iset(maxprocs) + integer(kind=2) :: i_index(maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) + real(kind=8) :: remd_ene(0:n_ene+4,maxprocs) + integer :: iremd_acc(maxprocs),iremd_tot(maxprocs) + integer :: iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs) + integer :: rstcount !el ilen, +!el external ilen + character(len=50) :: tytul +!el common /gucio/ cm + integer :: itime +!old integer nup(0:maxprocs),ndown(0:maxprocs) + integer :: rep2i(0:maxprocs),ireqi(maxprocs) + integer :: icache_all(maxprocs) + integer :: status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) + logical :: synflag, end_of_run, file_exist = .false.!, ovrtim + + real(kind=8) :: delta,time00,time01,time001,time02,time03,time04,& + time05,time06,time07,time08,tt0,scalfac,ene_iex_iex,& + ene_i_i,ene_iex_i,ene_i_iex,xxx,tmp,econstr_temp_i,& + econstr_temp_iex + integer :: k,il,il1,i,j,nharp,ii,ierr,itime_master,irr,iex,& + i_set_temp,itmp,i_temp,i_mult,i_iset,i_mset,i_dir,i_temp1,& + i_mult1,i_iset1,i_mset1,ierror + integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) +!deb imin_itime_old=0 + integer :: nres2 !el + nres2=2*nres + time001=0.0d0 + + ntwx_cache=0 + time00=MPI_WTIME() + time01=time00 + if(me.eq.king.or..not.out1file) then + write (iout,*) 'MREMD',nodes,'time before',time00-walltime + write (iout,*) "NREP=",nrep + endif + + synflag=.false. + if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst") + endif + mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" + +!d print *,'MREMD',nodes +!d print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) +!de write (iout,*) "Start MREMD: me",me," t_bath",t_bath + k=0 + rep2i(k)=-1 + do il=1,max0(nset,1) + do il1=1,max0(mset(il),1) + do i=1,nrep + iremd_acc(i)=0 + iremd_acc_usa(i)=0 + iremd_tot(i)=0 + do j=1,remd_m(i) + i2rep(k)=i + i2set(k)=il + rep2i(i)=k + k=k+1 + i_index(i,j,il,il1)=k + enddo + enddo + enddo + enddo + + if(me.eq.king.or..not.out1file) then + write(iout,*) (i2rep(i),i=0,nodes-1) + write(iout,*) (i2set(i),i=0,nodes-1) + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + write(iout,*) i,j,il,il1,i_index(i,j,il,il1) + enddo + enddo + enddo + enddo + endif + +! print *,'i2rep',me,i2rep(me) +! print *,'rep2i',(rep2i(i),i=0,nrep) + +!old if (i2rep(me).eq.nrep) then +!old nup(0)=0 +!old else +!old nup(0)=remd_m(i2rep(me)+1) +!old k=rep2i(int(i2rep(me)))+1 +!old do i=1,nup(0) +!old nup(i)=k +!old k=k+1 +!old enddo +!old endif + +!d print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) + +!old if (i2rep(me).eq.1) then +!old ndown(0)=0 +!old else +!old ndown(0)=remd_m(i2rep(me)-1) +!old k=rep2i(i2rep(me)-2)+1 +!old do i=1,ndown(0) +!old ndown(i)=k +!old k=k+1 +!old enddo +!old endif + +!d print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) + +!el common /przechowalnia/ + if(.not.allocated(d_restart1)) allocate(d_restart1(3,nres2*nodes)) + if(.not.allocated(d_restart2)) allocate(d_restart2(3,nres2*nodes)) + if(.not.allocated(p_c)) allocate(p_c(3,(nres2+2)*nodes)) +!el------------- + + write (*,*) "Processor",me," rest",rest,& + "restart1fie",restart1file + if(rest.and.restart1file) then + if (me.eq.king) & + inquire(file=mremd_rst_name,exist=file_exist) +!d write (*,*) me," Before broadcast: file_exist",file_exist + call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,& + IERR) +!d write (*,*) me," After broadcast: file_exist",file_exist + if(file_exist) then + if(me.eq.king.or..not.out1file) & + write (iout,*) 'Master is reading restart1file' + call read1restart(i_index) + else + if(me.eq.king.or..not.out1file) & + write (iout,*) 'WARNING : no restart1file' + endif + + if(me.eq.king.or..not.out1file) then + write(iout,*) "i2set",(i2set(i),i=0,nodes-1) + write(iout,*) "i_index" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + write(iout,*) i,j,il,il1,i_index(i,j,il,il1) + enddo + enddo + enddo + enddo + endif + endif + + if(me.eq.king) then + if (rest.and..not.restart1file) & + inquire(file=mremd_rst_name,exist=file_exist) + if(.not.file_exist.and.rest.and..not.restart1file) & + write(iout,*) 'WARNING : no restart file',mremd_rst_name + IF (rest.and.file_exist.and..not.restart1file) THEN + write (iout,*) 'Master is reading restart file',& + mremd_rst_name + open(irest2,file=mremd_rst_name,status='unknown') + read (irest2,*) + read (irest2,*) (i2rep(i),i=0,nodes-1) + read (irest2,*) + read (irest2,*) (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + read (irest2,*) + read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) + read (irest2,*) + read (irest2,*) ndowna(0,il),& + (ndowna(i,il),i=1,ndowna(0,il)) + enddo + if(usampl) then + read (irest2,*) + read (irest2,*) nset + read (irest2,*) + read (irest2,*) (mset(i),i=1,nset) + read (irest2,*) + read (irest2,*) (i2set(i),i=0,nodes-1) + read (irest2,*) + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i)) + enddo + enddo + enddo + + write(iout,*) "i2set",(i2set(i),i=0,nodes-1) + write(iout,*) "i_index" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + write(iout,*) i,j,il,il1,i_index(i,j,il,il1) + enddo + enddo + enddo + enddo + endif + + close(irest2) + + write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) + write (iout,'(a6,1000i5)') "ifirst",& + (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + write (iout,'(a6,i4,a1,100i4)') "nupa",il,":",& + (nupa(i,il),i=1,nupa(0,il)) + write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":",& + (ndowna(i,il),i=1,ndowna(0,il)) + enddo + ELSE IF (.not.(rest.and.file_exist)) THEN + do il=1,remd_m(1) + ifirst(il)=il + enddo + + do il=1,nodes + if (i2rep(il-1).eq.nrep) then + nupa(0,il)=0 + else + nupa(0,il)=remd_m(i2rep(il-1)+1) + k=rep2i(int(i2rep(il-1)))+1 + do i=1,nupa(0,il) + nupa(i,il)=k+1 + k=k+1 + enddo + endif + if (i2rep(il-1).eq.1) then + ndowna(0,il)=0 + else + ndowna(0,il)=remd_m(i2rep(il-1)-1) + k=rep2i(i2rep(il-1)-2)+1 + do i=1,ndowna(0,il) + ndowna(i,il)=k+1 + k=k+1 + enddo + endif + enddo + + write (iout,'(a6,100i4)') "ifirst",& + (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + write (iout,'(a6,i4,a1,100i4)') "nupa",il,":",& + (nupa(i,il),i=1,nupa(0,il)) + write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":",& + (ndowna(i,il),i=1,ndowna(0,il)) + enddo + + ENDIF + endif +! +! t_bath=retmin+(retmax-retmin)*me/(nodes-1) + if(.not.(rest.and.file_exist.and.restart1file)) then + if (me .eq. king) then + t_bath=retmin + else + t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) + endif +!d print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) + if (remd_tlist) t_bath=remd_t(int(i2rep(me))) + + endif + if(usampl) then + iset=i2set(me) + if(me.eq.king.or..not.out1file) & + write(iout,*) me,"iset=",iset,"t_bath=",t_bath + endif +! + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + +! print *,'irep',me,t_bath + if (.not.rest) then + if (me.eq.king .or. .not. out1file) & + write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath + call rescale_weights(t_bath) + endif + + +!------copy MD-------------- +! The driver for molecular dynamics subroutines +!------------------------------------------------ + t_MDsetup=0.0d0 + t_langsetup=0.0d0 + t_MD=0.0d0 + t_enegrad=0.0d0 + t_sdsetup=0.0d0 + if(me.eq.king.or..not.out1file) & + write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +! Determine the inverse of the inertia matrix. + call setup_MD_matrices +! Initialize MD + call init_MD + if (rest) then + if (me.eq.king .or. .not. out1file) & + write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + call rescale_weights(t_bath) + endif + +#ifdef MPI + t_MDsetup = MPI_Wtime()-tt0 +#else + t_MDsetup = tcpu()-tt0 +#endif + rstcount=0 +! Entering the MD loop +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#else + write (iout,*) & + "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif + time00=MPI_WTIME() + if (me.eq.king .or. .not. out1file) & + write(iout,*) 'Setup time',time00-walltime + call flush(iout) +#ifdef MPI + t_langsetup=MPI_Wtime()-tt0 + tt0=MPI_Wtime() +#else + t_langsetup=tcpu()-tt0 + tt0=tcpu() +#endif + itime=0 + end_of_run=.false. + + do while(.not.end_of_run) + itime=itime+1 + if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. + if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. + rstcount=rstcount+1 + if (lang.gt.0 .and. surfarea .and. & + mod(itime,reset_fricmat).eq.0) then + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif + write (iout,'(a,i10)') & + "Friction matrix reset based on surface area, itime",itime + endif + if (reset_vel .and. tbf .and. lang.eq.0 & + .and. mod(itime,count_reset_vel).eq.0) then + call random_vel + if (me.eq.king .or. .not. out1file) & + write(iout,'(a,f20.2)') & + "Velocities reset to random values, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + enddo + enddo + endif + if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then + call inertia_tensor + call vcm_vel(vcm) + do j=1,3 + d_t(j,0)=d_t(j,0)-vcm(j) + enddo + call kinetic(EK) + kinetic_T=2.0d0/(dimen3*Rb)*EK + scalfac=dsqrt(T_bath/kinetic_T) +!d write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=scalfac*d_t(j,i) + enddo + enddo + endif + if (lang.ne.4) then + if (RESPA) then +! Time-reversible RESPA algorithm +! (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) + call RESPA_step(itime) + else +! Variable time step algorithm. + call velverlet_step(itime) + endif + else +#ifdef BROWN + call brown_step(itime) +#else + print *,"Brown dynamics not here!" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif + if(ntwe.ne.0) then + if (mod(itime,ntwe).eq.0) call statout(itime) + endif + if (mod(itime,ntwx).eq.0.and..not.traj1file) then + write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath + if(mdpdb) then + call hairpin(.true.,nharp,iharp) + call secondary2(.true.) + call pdbout(potE,tytul,ipdb) + else + call cartout(totT) + endif + endif + if (mod(itime,ntwx).eq.0.and.traj1file) then + if(ntwx_cache.lt.max_cache_traj_use) then + ntwx_cache=ntwx_cache+1 + else + if (max_cache_traj_use.ne.1) & + print *,itime,"processor ",me," over cache ",ntwx_cache + do i=1,ntwx_cache-1 + + totT_cache(i)=totT_cache(i+1) + EK_cache(i)=EK_cache(i+1) + potE_cache(i)=potE_cache(i+1) + t_bath_cache(i)=t_bath_cache(i+1) + Uconst_cache(i)=Uconst_cache(i+1) + iset_cache(i)=iset_cache(i+1) + + do ii=1,nfrag + qfrag_cache(ii,i)=qfrag_cache(ii,i+1) + enddo + do ii=1,npair + qpair_cache(ii,i)=qpair_cache(ii,i+1) + enddo + do ii=1,nfrag_back + utheta_cache(ii,i)=utheta_cache(ii,i+1) + ugamma_cache(ii,i)=ugamma_cache(ii,i+1) + uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1) + enddo + + + do ii=1,nres*2 + do j=1,3 + c_cache(j,ii,i)=c_cache(j,ii,i+1) + enddo + enddo + enddo + endif + + totT_cache(ntwx_cache)=totT + EK_cache(ntwx_cache)=EK + potE_cache(ntwx_cache)=potE + t_bath_cache(ntwx_cache)=t_bath + Uconst_cache(ntwx_cache)=Uconst + iset_cache(ntwx_cache)=iset + + do i=1,nfrag + qfrag_cache(i,ntwx_cache)=qfrag(i) + enddo + do i=1,npair + qpair_cache(i,ntwx_cache)=qpair(i) + enddo + do i=1,nfrag_back + utheta_cache(i,ntwx_cache)=utheta(i) + ugamma_cache(i,ntwx_cache)=ugamma(i) + uscdiff_cache(i,ntwx_cache)=uscdiff(i) + enddo + + do i=1,nres*2 + do j=1,3 + c_cache(j,i,ntwx_cache)=c(j,i) + enddo + enddo + + endif + if ((rstcount.eq.1000.or.itime.eq.n_timestep) & + .and..not.restart1file) then + + if(me.eq.king) then + open(irest1,file=mremd_rst_name,status='unknown') + write (irest1,*) "i2rep" + write (irest1,*) (i2rep(i),i=0,nodes-1) + write (irest1,*) "ifirst" + write (irest1,*) (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + write (irest1,*) "nupa",il + write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) + write (irest1,*) "ndowna",il + write (irest1,*) ndowna(0,il),& + (ndowna(i,il),i=1,ndowna(0,il)) + enddo + if(usampl) then + write (irest1,*) "nset" + write (irest1,*) nset + write (irest1,*) "mset" + write (irest1,*) (mset(i),i=1,nset) + write (irest1,*) "i2set" + write (irest1,*) (i2set(i),i=0,nodes-1) + write (irest1,*) "i_index" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) + enddo + enddo + enddo + + endif + close(irest1) + endif + open(irest2,file=rest2name,status='unknown') + write(irest2,*) totT,EK,potE,totE,t_bath + do i=1,2*nres + write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) + enddo + do i=1,2*nres + write (irest2,'(3e15.5)') (dc(j,i),j=1,3) + enddo + if(usampl) then + write (irest2,*) iset + endif + close(irest2) + rstcount=0 + endif + +! REMD - exchange +! forced synchronization + if (mod(itime,i_sync_step).eq.0 .and. me.ne.king & + .and. .not. mremdsync) then + synflag=.false. + call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) + if (synflag) then + call mpi_recv(itime_master, 1, MPI_INTEGER,& + 0,101,CG_COMM, status, ierr) + call mpi_barrier(CG_COMM, ierr) +!deb if (out1file.or.traj1file) then +!deb call mpi_gather(itime,1,mpi_integer, +!deb & icache_all,1,mpi_integer,king, +!deb & CG_COMM,ierr) + if(traj1file) & + call mpi_gather(ntwx_cache,1,mpi_integer,& + icache_all,1,mpi_integer,king,& + CG_COMM,ierr) + if (.not.out1file) & + write(iout,*) 'REMD synchro at',itime_master,itime + if (itime_master.ge.n_timestep .or. ovrtim()) & + end_of_run=.true. +!time call flush(iout) + endif + endif + +! REMD - exchange + if ((mod(itime,nstex).eq.0.and.me.eq.king & + .or.end_of_run.and.me.eq.king ) & + .and. .not. mremdsync ) then + synflag=.true. + do i=1,nodes-1 + call mpi_isend(itime,1,MPI_INTEGER,i,101, & + CG_COMM, ireqi(i), ierr) +!d write(iout,*) 'REMD synchro with',i +!d call flush(iout) + enddo + call mpi_waitall(nodes-1,ireqi,statusi,ierr) + call mpi_barrier(CG_COMM, ierr) + time01=MPI_WTIME() + write(iout,*) 'REMD synchro at',itime,'time=',time01-time00 + if (out1file.or.traj1file) then +!deb call mpi_gather(itime,1,mpi_integer, +!deb & itime_all,1,mpi_integer,king, +!deb & CG_COMM,ierr) +!deb write(iout,'(a19,8000i8)') ' REMD synchro itime', +!deb & (itime_all(i),i=1,nodes) + if(traj1file) then +!deb imin_itime=itime_all(1) +!deb do i=2,nodes +!deb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) +!deb enddo +!deb ii_write=(imin_itime-imin_itime_old)/ntwx +!deb imin_itime_old=int(imin_itime/ntwx)*ntwx +!deb write(iout,*) imin_itime,imin_itime_old,ii_write + call mpi_gather(ntwx_cache,1,mpi_integer,& + icache_all,1,mpi_integer,king,& + CG_COMM,ierr) +! write(iout,'(a19,8000i8)') ' ntwx_cache', +! & (icache_all(i),i=1,nodes) + ii_write=icache_all(1) + do i=2,nodes + if(icache_all(i).lt.ii_write) ii_write=icache_all(i) + enddo +! write(iout,*) "MIN ii_write=",ii_write + endif + endif +!time call flush(iout) + endif + if(mremdsync .and. mod(itime,nstex).eq.0) then + synflag=.true. + if (me.eq.king .or. .not. out1file) & + write(iout,*) 'REMD synchro at',itime + + if(traj1file) then + call mpi_gather(ntwx_cache,1,mpi_integer,& + icache_all,1,mpi_integer,king,& + CG_COMM,ierr) + if (me.eq.king) then + write(iout,'(a19,8000i8)') ' ntwx_cache',& + (icache_all(i),i=1,nodes) + ii_write=icache_all(1) + do i=2,nodes + if(icache_all(i).lt.ii_write) ii_write=icache_all(i) + enddo + write(iout,*) "MIN ii_write=",ii_write + endif + endif + call flush(iout) + endif + if (synflag) then +! Update the time safety limiy + if (time001-time00.gt.safety) then + safety=time001-time00+600 + write (iout,*) "****** SAFETY increased to",safety," s" + endif + if (ovrtim()) end_of_run=.true. + endif + if(synflag.and..not.end_of_run) then + time02=MPI_WTIME() + synflag=.false. + + write(iout,*) 'REMD before',me,t_bath + +! call mpi_gather(t_bath,1,mpi_double_precision, +! & remd_t_bath,1,mpi_double_precision,king, +! & CG_COMM,ierr) + potEcomp(n_ene+1)=t_bath + if (usampl) then + potEcomp(n_ene+2)=iset + if (iset.lt.nset) then + i_set_temp=iset + iset=iset+1 + call EconstrQ + potEcomp(n_ene+3)=Uconst + iset=i_set_temp + endif + if (iset.gt.1) then + i_set_temp=iset + iset=iset-1 + call EconstrQ + potEcomp(n_ene+4)=Uconst + iset=i_set_temp + endif + endif + call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision,& + remd_ene(0,1),n_ene+5,mpi_double_precision,king,& + CG_COMM,ierr) + if(lmuca) then + call mpi_gather(elow,1,mpi_double_precision,& + elowi,1,mpi_double_precision,king,& + CG_COMM,ierr) + call mpi_gather(ehigh,1,mpi_double_precision,& + ehighi,1,mpi_double_precision,king,& + CG_COMM,ierr) + endif + + time03=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD gather times=',time03-time01 & + ,time03-time02 + endif + + if (restart1file) call write1rst(i_index) + + time04=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD writing rst time=',time04-time03 + endif + + if (traj1file) call write1traj +!d debugging +!deb call mpi_gather(ntwx_cache,1,mpi_integer, +!deb & icache_all,1,mpi_integer,king, +!deb & CG_COMM,ierr) +!deb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file', +!deb & (icache_all(i),i=1,nodes) +!d end + + + time05=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD writing traj time=',time05-time04 + call flush(iout) + endif + + + if (me.eq.king) then + do i=1,nodes + remd_t_bath(i)=remd_ene(n_ene+1,i) + iremd_iset(i)=remd_ene(n_ene+2,i) + enddo +#ifdef DEBUG + if(lmuca) then +!o write(iout,*) 'REMD exchange temp,ene,elow,ehigh' + do i=1,nodes + write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i),& + elowi(i),ehighi(i) + enddo + else + write(iout,*) 'REMD exchange temp,ene' + do i=1,nodes + write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) + write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) + enddo + endif +#endif +!------------------------------------- + IF(.not.usampl) THEN + write (iout,*) "Enter exchnge, remd_m",remd_m(1),& + " nodes",nodes + call flush(iout) + write (iout,*) "remd_m(1)",remd_m(1) + do irr=1,remd_m(1) + i=ifirst(iran_num(1,remd_m(1))) + write (iout,*) "i",i + call flush(iout) + + do ii=1,nodes-1 + +#ifdef DEBUG + write (iout,*) "i",i," nupa(0,i)",int(nupa(0,i)) +#endif + if(i.gt.0.and.nupa(0,i).gt.0) then + iex=i +! if (i.eq.1 .and. int(nupa(0,i)).eq.1) then +! write (iout,*) +! & "CHUJ ABSOLUTNY!!! No way to sample a distinct replica in MREMD" +! call flush(iout) +! call MPI_Abort(MPI_COMM_WORLD,ERRCODE,ierr) +! endif +! do while (iex.eq.i) +! write (iout,*) "upper",nupa(int(nupa(0,i)),i) + iex=nupa(iran_num(1,int(nupa(0,i))),i) +! enddo +! write (iout,*) "nupa(0,i)",nupa(0,i)," iex",iex + if (lmuca) then + call muca_delta(remd_t_bath,remd_ene,i,iex,delta) + else +! Swap temperatures between conformations i and iex with recalculating the free energies +! following temperature changes. + ene_iex_iex=remd_ene(0,iex) + ene_i_i=remd_ene(0,i) +! write (iout,*) "i",i," ene_i_i",ene_i_i, +! & " iex",iex," ene_iex_iex",ene_iex_iex +! write (iout,*) "rescaling weights with temperature", +! & remd_t_bath(i) +! call flush(iout) + call rescale_weights(remd_t_bath(i)) + +! write (iout,*) "0,iex",remd_t_bath(i) +! call enerprint(remd_ene(0,iex)) + + call sum_energy(remd_ene(0,iex),.false.) + ene_iex_i=remd_ene(0,iex) +! write (iout,*) "ene_iex_i",remd_ene(0,iex) + +! write (iout,*) "0,i",remd_t_bath(i) +! call enerprint(remd_ene(0,i)) + + call sum_energy(remd_ene(0,i),.false.) +! write (iout,*) "ene_i_i",remd_ene(0,i) +! call flush(iout) +! write (iout,*) "rescaling weights with temperature", +! & remd_t_bath(iex) + if (real(ene_i_i).ne.real(remd_ene(0,i))) then + write (iout,*) "ERROR: inconsistent energies:",i,& + ene_i_i,remd_ene(0,i) + endif + call rescale_weights(remd_t_bath(iex)) + +! write (iout,*) "0,i",remd_t_bath(iex) +! call enerprint(remd_ene(0,i)) + + call sum_energy(remd_ene(0,i),.false.) +! write (iout,*) "ene_i_iex",remd_ene(0,i) +! call flush(iout) + ene_i_iex=remd_ene(0,i) + +! write (iout,*) "0,iex",remd_t_bath(iex) +! call enerprint(remd_ene(0,iex)) + + call sum_energy(remd_ene(0,iex),.false.) + if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then + write (iout,*) "ERROR: inconsistent energies:",iex,& + ene_iex_iex,remd_ene(0,iex) + endif +! write (iout,*) "ene_iex_iex",remd_ene(0,iex) +! write (iout,*) "i",i," iex",iex +! write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, +! & " ene_i_iex",ene_i_iex, +! & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex +! call flush(iout) + delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- & + (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) + delta=-delta +! write(iout,*) 'delta',delta +! delta=(remd_t_bath(i)-remd_t_bath(iex))* +! & (remd_ene(i)-remd_ene(iex))/Rb/ +! & (remd_t_bath(i)*remd_t_bath(iex)) + endif + if (delta .gt. 50.0d0) then + delta=0.0d0 + else +#ifdef OSF + if(isnan(delta))then + delta=0.0d0 + else if (delta.lt.-50.0d0) then + delta=dexp(50.0d0) + else + delta=dexp(-delta) + endif +#else + delta=dexp(-delta) +#endif + endif + iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 + xxx=ran_number(0.0d0,1.0d0) +! write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx +! call flush(iout) + if (delta .gt. xxx) then + tmp=remd_t_bath(i) + remd_t_bath(i)=remd_t_bath(iex) + remd_t_bath(iex)=tmp + remd_ene(0,i)=ene_i_iex + remd_ene(0,iex)=ene_iex_i + if(lmuca) then + tmp=elowi(i) + elowi(i)=elowi(iex) + elowi(iex)=tmp + tmp=ehighi(i) + ehighi(i)=ehighi(iex) + ehighi(iex)=tmp + endif + + + do k=0,nodes + itmp=nupa(k,i) + nupa(k,i)=nupa(k,iex) + nupa(k,iex)=itmp + itmp=ndowna(k,i) + ndowna(k,i)=ndowna(k,iex) + ndowna(k,iex)=itmp + enddo + do il=1,nodes + if (ifirst(il).eq.i) ifirst(il)=iex + do k=1,nupa(0,il) + if (nupa(k,il).eq.i) then + nupa(k,il)=iex + elseif (nupa(k,il).eq.iex) then + nupa(k,il)=i + endif + enddo + do k=1,ndowna(0,il) + if (ndowna(k,il).eq.i) then + ndowna(k,il)=iex + elseif (ndowna(k,il).eq.iex) then + ndowna(k,il)=i + endif + enddo + enddo + + iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 + itmp=i2rep(i-1) + i2rep(i-1)=i2rep(iex-1) + i2rep(iex-1)=itmp + +! write(iout,*) 'exchange',i,iex +! write (iout,'(a8,100i4)') "@ ifirst", +! & (ifirst(k),k=1,remd_m(1)) +! do il=1,nodes +! write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", +! & (nupa(k,il),k=1,nupa(0,il)) +! write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", +! & (ndowna(k,il),k=1,ndowna(0,il)) +! enddo +! call flush(iout) + + else + remd_ene(0,iex)=ene_iex_iex + remd_ene(0,i)=ene_i_i + i=iex + endif + endif + enddo + enddo +!d write (iout,*) "exchange completed" +!d call flush(iout) + ELSE + do ii=1,nodes +!d write(iout,*) "########",ii + + i_temp=iran_num(1,nrep) + i_mult=iran_num(1,remd_m(i_temp)) + i_iset=iran_num(1,nset) + i_mset=iran_num(1,mset(i_iset)) + i=i_index(i_temp,i_mult,i_iset,i_mset) + +!d write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset + + i_dir=iran_num(1,3) +!d write(iout,*) "i_dir=",i_dir + + if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then + + i_temp1=i_temp+1 + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset + i_mset1=iran_num(1,mset(i_iset1)) + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + + elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then + + i_temp1=i_temp + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset+1 + i_mset1=iran_num(1,mset(i_iset1)) + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + econstr_temp_i=remd_ene(20,i) + econstr_temp_iex=remd_ene(20,iex) + remd_ene(20,i)=remd_ene(n_ene+3,i) + remd_ene(20,iex)=remd_ene(n_ene+4,iex) + + elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then + + i_temp1=i_temp+1 + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset+1 + i_mset1=iran_num(1,mset(i_iset1)) + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + econstr_temp_i=remd_ene(20,i) + econstr_temp_iex=remd_ene(20,iex) + remd_ene(20,i)=remd_ene(n_ene+3,i) + remd_ene(20,iex)=remd_ene(n_ene+4,iex) + + else + goto 444 + endif + +!d write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 + call flush(iout) + +! Swap temperatures between conformations i and iex with recalculating the free energies +! following temperature changes. + ene_iex_iex=remd_ene(0,iex) + ene_i_i=remd_ene(0,i) +!o write (iout,*) "rescaling weights with temperature", +!o & remd_t_bath(i) + call rescale_weights(remd_t_bath(i)) + + call sum_energy(remd_ene(0,iex),.false.) + ene_iex_i=remd_ene(0,iex) +!d write (iout,*) "ene_iex_i",remd_ene(0,iex) +! call sum_energy(remd_ene(0,i),.false.) +!d write (iout,*) "ene_i_i",remd_ene(0,i) +! write (iout,*) "rescaling weights with temperature", +! & remd_t_bath(iex) +! if (real(ene_i_i).ne.real(remd_ene(0,i))) then +! write (iout,*) "ERROR: inconsistent energies:",i, +! & ene_i_i,remd_ene(0,i) +! endif + call rescale_weights(remd_t_bath(iex)) + call sum_energy(remd_ene(0,i),.false.) +!d write (iout,*) "ene_i_iex",remd_ene(0,i) + ene_i_iex=remd_ene(0,i) +! call sum_energy(remd_ene(0,iex),.false.) +! if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then +! write (iout,*) "ERROR: inconsistent energies:",iex, +! & ene_iex_iex,remd_ene(0,iex) +! endif +!d write (iout,*) "ene_iex_iex",remd_ene(0,iex) +! write (iout,*) "i",i," iex",iex +!d write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, +!d & " ene_i_iex",ene_i_iex, +!d & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex + delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- & + (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) + delta=-delta +!d write(iout,*) 'delta',delta +! delta=(remd_t_bath(i)-remd_t_bath(iex))* +! & (remd_ene(i)-remd_ene(iex))/Rb/ +! & (remd_t_bath(i)*remd_t_bath(iex)) + if (delta .gt. 50.0d0) then + delta=0.0d0 + else + delta=dexp(-delta) + endif + if (i_dir.eq.1.or.i_dir.eq.3) & + iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 + if (i_dir.eq.2.or.i_dir.eq.3) & + iremd_tot_usa(int(i2set(i-1)))= & + iremd_tot_usa(int(i2set(i-1)))+1 + xxx=ran_number(0.0d0,1.0d0) +!d write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx + if (delta .gt. xxx) then + tmp=remd_t_bath(i) + remd_t_bath(i)=remd_t_bath(iex) + remd_t_bath(iex)=tmp + + itmp=iremd_iset(i) + iremd_iset(i)=iremd_iset(iex) + iremd_iset(iex)=itmp + + remd_ene(0,i)=ene_i_iex + remd_ene(0,iex)=ene_iex_i + + if (i_dir.eq.1.or.i_dir.eq.3) & + iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 + + itmp=i2rep(i-1) + i2rep(i-1)=i2rep(iex-1) + i2rep(iex-1)=itmp + + if (i_dir.eq.2.or.i_dir.eq.3) & + iremd_acc_usa(int(i2set(i-1)))= & + iremd_acc_usa(int(i2set(i-1)))+1 + + itmp=i2set(i-1) + i2set(i-1)=i2set(iex-1) + i2set(iex-1)=itmp + + itmp=i_index(i_temp,i_mult,i_iset,i_mset) + i_index(i_temp,i_mult,i_iset,i_mset)= & + i_index(i_temp1,i_mult1,i_iset1,i_mset1) + i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp + + else + remd_ene(0,iex)=ene_iex_iex + remd_ene(0,i)=ene_i_i + remd_ene(20,iex)=econstr_temp_iex + remd_ene(20,i)=econstr_temp_i + endif + +!d do il=1,nset +!d do il1=1,mset(il) +!d do i=1,nrep +!d do j=1,remd_m(i) +!d write(iout,*) i,j,il,il1,i_index(i,j,il,il1) +!d enddo +!d enddo +!d enddo +!d enddo + + 444 continue + + enddo + + + ENDIF + +!------------------------------------- + write (iout,*) "NREP",nrep + do i=1,nrep + if(iremd_tot(i).ne.0) & + write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i) & + ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i) + enddo + + if(usampl) then + do i=1,nset + if(iremd_tot_usa(i).ne.0) & + write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i,& + iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) + enddo + endif + + call flush(iout) + +!d write (iout,'(a6,100i4)') "ifirst", +!d & (ifirst(i),i=1,remd_m(1)) +!d do il=1,nodes +!d write (iout,'(a5,i4,a1,100i4)') "nup",il,":", +!d & (nupa(i,il),i=1,nupa(0,il)) +!d write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", +!d & (ndowna(i,il),i=1,ndowna(0,il)) +!d enddo + endif + + time06=MPI_WTIME() +!d write (iout,*) "Before scatter" +!d call flush(iout) +#ifdef DEBUG + if (me.eq.king) then + write (iout,*) "t_bath before scatter",remd_t_bath + call flush(iout) + endif +#endif + call mpi_scatter(remd_t_bath,1,mpi_double_precision,& + t_bath,1,mpi_double_precision,king,& + CG_COMM,ierr) +!d write (iout,*) "After scatter" +!d call flush(iout) + if(usampl) & + call mpi_scatter(iremd_iset,1,mpi_integer,& + iset,1,mpi_integer,king,& + CG_COMM,ierr) + + time07=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD scatter time=',time07-time06 + endif + + if(lmuca) then + call mpi_scatter(elowi,1,mpi_double_precision,& + elow,1,mpi_double_precision,king,& + CG_COMM,ierr) + call mpi_scatter(ehighi,1,mpi_double_precision,& + ehigh,1,mpi_double_precision,king,& + CG_COMM,ierr) + endif + call rescale_weights(t_bath) +!o write (iout,*) "Processor",me, +!o & " rescaling weights with temperature",t_bath + + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + +!de write(iout,*) 'REMD after',me,t_bath + time08=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD exchange time 8-0=',time08-time00 + write(iout,*) 'REMD exchange time 8-7=',time08-time07 + write(iout,*) 'REMD exchange time 7-6=',time07-time06 + write(iout,*) 'REMD exchange time 6-5=',time06-time05 + write(iout,*) 'REMD exchange time 5-4=',time05-time04 + write(iout,*) 'REMD exchange time 4-3=',time04-time03 + write(iout,*) 'REMD exchange time 3-2=',time03-time02 + write(iout,*) 'REMD exchange time 2-1=',time02-time01 + write(iout,*) 'REMD exchange time 1-0=',time01-time00 + call flush(iout) + endif + endif + enddo + + if (restart1file) then + if (me.eq.king .or. .not. out1file) & + write(iout,*) 'writing restart at the end of run' + call write1rst(i_index) + endif + + if (traj1file) call write1traj +!d debugging +!deb call mpi_gather(ntwx_cache,1,mpi_integer, +!deb & icache_all,1,mpi_integer,king, +!deb & CG_COMM,ierr) +!deb write(iout,'(a40,8000i8)') +!deb & ' ntwx_cache after traj1file at the end', +!deb & (icache_all(i),i=1,nodes) +!d end + + +#ifdef MPI + t_MD=MPI_Wtime()-tt0 +#else + t_MD=tcpu()-tt0 +#endif + if (me.eq.king .or. .not. out1file) then + write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') & + ' Timing ',& + 'MD calculations setup:',t_MDsetup,& + 'Energy & gradient evaluation:',t_enegrad,& + 'Stochastic MD setup:',t_langsetup,& + 'Stochastic MD step setup:',t_sdsetup,& + 'MD steps:',t_MD + write (iout,'(/28(1h=),a25,27(1h=))') & + ' End of MD calculation ' + endif +!el common /przechowalnia/ +! deallocate(d_restart1) +! deallocate(d_restart2) +! deallocate(p_c) +!el-------------- + return + end subroutine MREMD +!----------------------------------------------------------------------------- + subroutine write1rst(i_index) + + use control_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.SBRIDGE' +! include 'COMMON.INTERACT' + +!el real(kind=4) :: d_restart1(3,2*nres*maxprocs),& +!el d_restart2(3,2*nres*maxprocs) + real(kind=4) :: r_d(3,2*nres) + real(kind=4) :: t5_restart1(5) + integer :: iret,itmp + integer(kind=2) :: i_index(maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) +!el common /przechowalnia/ d_restart1,d_restart2 + integer :: i,j,il,il1,ierr,ixdrf + + t5_restart1(1)=totT + t5_restart1(2)=EK + t5_restart1(3)=potE + t5_restart1(4)=t_bath + t5_restart1(5)=Uconst + + call mpi_gather(t5_restart1,5,mpi_real,& + t_restart1,5,mpi_real,king,CG_COMM,ierr) + + + do i=1,2*nres + do j=1,3 + r_d(j,i)=d_t(j,i) + enddo + enddo + call mpi_gather(r_d,3*2*nres,mpi_real,& + d_restart1,3*2*nres,mpi_real,king,& + CG_COMM,ierr) + + + do i=1,2*nres + do j=1,3 + r_d(j,i)=dc(j,i) + enddo + enddo + call mpi_gather(r_d,3*2*nres,mpi_real,& + d_restart2,3*2*nres,mpi_real,king,& + CG_COMM,ierr) + + if(me.eq.king) then +#ifdef AIX + call xdrfopen_(ixdrf,mremd_rst_name, "w", iret) + do i=0,nodes-1 + call xdrfint_(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint_(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + do i=0,nupa(0,il) + call xdrfint_(ixdrf, nupa(i,il), iret) + enddo + + do i=0,ndowna(0,il) + call xdrfint_(ixdrf, ndowna(i,il), iret) + enddo + enddo + + do il=1,nodes + do j=1,4 + call xdrffloat_(ixdrf, t_restart1(j,il), iret) + enddo + enddo + + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) + enddo + enddo + enddo + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat_(ixdrf, d_restart2(j,i+2*nres*il), iret) + enddo + enddo + enddo + + if(usampl) then + call xdrfint_(ixdrf, nset, iret) + do i=1,nset + call xdrfint_(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint_(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + itmp=i_index(i,j,il,il1) + call xdrfint_(ixdrf,itmp, iret) + enddo + enddo + enddo + enddo + + endif + call xdrfclose_(ixdrf, iret) +#else + call xdrfopen(ixdrf,mremd_rst_name, "w", iret) + do i=0,nodes-1 + call xdrfint(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + do i=0,nupa(0,il) + call xdrfint(ixdrf, nupa(i,il), iret) + enddo + + do i=0,ndowna(0,il) + call xdrfint(ixdrf, ndowna(i,il), iret) + enddo + enddo + + do il=1,nodes + do j=1,4 + call xdrffloat(ixdrf, t_restart1(j,il), iret) + enddo + enddo + + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) + enddo + enddo + enddo + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) + enddo + enddo + enddo + + + if(usampl) then + call xdrfint(ixdrf, nset, iret) + do i=1,nset + call xdrfint(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + itmp=i_index(i,j,il,il1) + call xdrfint(ixdrf,itmp, iret) + enddo + enddo + enddo + enddo + + endif + call xdrfclose(ixdrf, iret) +#endif + endif + return + end subroutine write1rst +!----------------------------------------------------------------------------- + subroutine write1traj + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.SBRIDGE' +! include 'COMMON.INTERACT' + + real(kind=4) :: t5_restart1(5) + integer :: iret,itmp + real(kind=4) :: xcoord(3,2*nres+2),prec + real(kind=4) :: r_qfrag(50),r_qpair(100) + real(kind=4) :: r_utheta(50),r_ugamma(100),r_uscdiff(100) + real(kind=4) :: p_qfrag(50*maxprocs),p_qpair(100*maxprocs) + real(kind=4) :: p_utheta(50*maxprocs),p_ugamma(100*maxprocs),& + p_uscdiff(100*maxprocs) +!el real(kind=4) :: p_c(3,(nres2+2)*maxprocs) + real(kind=4) :: r_c(3,2*nres+2) +!el common /przechowalnia/ p_c + + integer :: i,j,il,ierr,ii,ixdrf + + call mpi_bcast(ii_write,1,mpi_integer,& + king,CG_COMM,ierr) + +! debugging + print *,'traj1file',me,ii_write,ntwx_cache +! end debugging + +#ifdef AIX + if(me.eq.king) call xdrfopen_(ixdrf,cartname, "a", iret) +#else + if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) +#endif + do ii=1,ii_write +! write (iout,*) "before gather write1traj: from node",ii +! call flush(iout) +! write (iout,*) totT_cache(ii),EK_cache(ii),potE_cache(ii),t_bath_cache(ii),Uconst_cache(ii) +! call flush(iout) + t5_restart1(1)=totT_cache(ii) + t5_restart1(2)=EK_cache(ii) + t5_restart1(3)=potE_cache(ii) + t5_restart1(4)=t_bath_cache(ii) + t5_restart1(5)=Uconst_cache(ii) +! write (iout,*) "before gather write1traj: from node",ii,t5_restart1(1),t5_restart1(3),t5_restart1(5),t5_restart1(4) + call flush(iout) + call mpi_gather(t5_restart1,5,mpi_real,& + t_restart1,5,mpi_real,king,CG_COMM,ierr) +! do il=1,nodes +! write (iout,*) "after gather write1traj: from node",il,t_restart1(1,il),t_restart1(3,il),t_restart1(5,il),t_restart1(4,il) +! enddo + + call mpi_gather(iset_cache(ii),1,mpi_integer,& + iset_restart1,1,mpi_integer,king,CG_COMM,ierr) + + do i=1,nfrag + r_qfrag(i)=qfrag_cache(i,ii) + enddo + do i=1,npair + r_qpair(i)=qpair_cache(i,ii) + enddo + do i=1,nfrag_back + r_utheta(i)=utheta_cache(i,ii) + r_ugamma(i)=ugamma_cache(i,ii) + r_uscdiff(i)=uscdiff_cache(i,ii) + enddo + + call mpi_gather(r_qfrag,nfrag,mpi_real,& + p_qfrag,nfrag,mpi_real,king,& + CG_COMM,ierr) + call mpi_gather(r_qpair,npair,mpi_real,& + p_qpair,npair,mpi_real,king,& + CG_COMM,ierr) + call mpi_gather(r_utheta,nfrag_back,mpi_real,& + p_utheta,nfrag_back,mpi_real,king,& + CG_COMM,ierr) + call mpi_gather(r_ugamma,nfrag_back,mpi_real,& + p_ugamma,nfrag_back,mpi_real,king,& + CG_COMM,ierr) + call mpi_gather(r_uscdiff,nfrag_back,mpi_real,& + p_uscdiff,nfrag_back,mpi_real,king,& + CG_COMM,ierr) + +#ifdef DEBUG + write (iout,*) "p_qfrag" + do i=1,nodes + write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag) + enddo + write (iout,*) "p_qpair" + do i=1,nodes + write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair) + enddo + call flush(iout) +#endif + do i=1,nres*2 + do j=1,3 + r_c(j,i)=c_cache(j,i,ii) + enddo + enddo + + call mpi_gather(r_c,3*2*nres,mpi_real,& + p_c,3*2*nres,mpi_real,king,& + CG_COMM,ierr) + + if(me.eq.king) then +#ifdef AIX + do il=1,nodes + call xdrffloat_(ixdrf, real(t_restart1(1,il)), iret) + call xdrffloat_(ixdrf, real(t_restart1(3,il)), iret) + call xdrffloat_(ixdrf, real(t_restart1(5,il)), iret) + call xdrffloat_(ixdrf, real(t_restart1(4,il)), iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) + call xdrfint_(ixdrf, iset_restart1(il), iret) + do i=1,nfrag + call xdrffloat_(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) + enddo + do i=1,npair + call xdrffloat_(ixdrf, p_qpair(i+(il-1)*npair), iret) + enddo + do i=1,nfrag_back + call xdrffloat_(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) + call xdrffloat_(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) + call xdrffloat_(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) + enddo + prec=10000.0 + do i=1,nres + do j=1,3 + xcoord(j,i)=p_c(j,i+(il-1)*nres*2) + enddo + enddo + do i=nnt,nct + do j=1,3 + xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) + enddo + enddo + itmp=nres+nct-nnt+1 + call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) + enddo +#else + do il=1,nodes + call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) + call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) + call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) + call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) +! write (iout,*) "write1traj: from node",ii,t_restart1(1,il),t_restart1(3,il),t_restart1(5,il),t_restart1(4,il) + call xdrfint(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) + call xdrfint(ixdrf, iset_restart1(il), iret) + do i=1,nfrag + call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) + enddo + do i=1,npair + call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) + enddo + do i=1,nfrag_back + call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) + call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) + call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) + enddo + prec=10000.0 + do i=1,nres + do j=1,3 + xcoord(j,i)=p_c(j,i+(il-1)*nres*2) + enddo + enddo + do i=nnt,nct + do j=1,3 + xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) + enddo + enddo + itmp=nres+nct-nnt+1 + call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) + enddo +#endif + endif + enddo +#ifdef AIX + if(me.eq.king) call xdrfclose_(ixdrf, iret) +#else + if(me.eq.king) call xdrfclose(ixdrf, iret) +#endif + do i=1,ntwx_cache-ii_write + + totT_cache(i)=totT_cache(ii_write+i) + EK_cache(i)=EK_cache(ii_write+i) + potE_cache(i)=potE_cache(ii_write+i) + t_bath_cache(i)=t_bath_cache(ii_write+i) + Uconst_cache(i)=Uconst_cache(ii_write+i) + iset_cache(i)=iset_cache(ii_write+i) + + do ii=1,nfrag + qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) + enddo + do ii=1,npair + qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) + enddo + do ii=1,nfrag_back + utheta_cache(ii,i)=utheta_cache(ii,ii_write+i) + ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i) + uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i) + enddo + + do ii=1,nres*2 + do j=1,3 + c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) + enddo + enddo + enddo + ntwx_cache=ntwx_cache-ii_write + return + end subroutine write1traj +!----------------------------------------------------------------------------- + subroutine read1restart(i_index) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.SBRIDGE' +! include 'COMMON.INTERACT' +!el real(kind=4) :: d_restart1(3,2*nres*maxprocs) + real(kind=4) :: r_d(3,2*nres),t5_restart1(5) + integer(kind=2) :: i_index(maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) +!el common /przechowalnia/ d_restart1 + integer :: i,j,il,il1,ierr,itmp,iret,ixdrf + + write (*,*) "Processor",me," called read1restart" + + if(me.eq.king)then + open(irest2,file=mremd_rst_name,status='unknown') + read(irest2,*,err=334) i + write(iout,*) "Reading old rst in ASCI format" + close(irest2) + call read1restart_old + return + 334 continue +#ifdef AIX + call xdrfopen_(ixdrf,mremd_rst_name, "r", iret) + + do i=0,nodes-1 + call xdrfint_(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint_(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + call xdrfint_(ixdrf, nupa(0,il), iret) + do i=1,nupa(0,il) + call xdrfint_(ixdrf, nupa(i,il), iret) + enddo + + call xdrfint_(ixdrf, ndowna(0,il), iret) + do i=1,ndowna(0,il) + call xdrfint_(ixdrf, ndowna(i,il), iret) + enddo + enddo + do il=1,nodes + do j=1,4 + call xdrffloat_(ixdrf, t_restart1(j,il), iret) + enddo + enddo +#else + call xdrfopen(ixdrf,mremd_rst_name, "r", iret) + + do i=0,nodes-1 + call xdrfint(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + call xdrfint(ixdrf, nupa(0,il), iret) + do i=1,nupa(0,il) + call xdrfint(ixdrf, nupa(i,il), iret) + enddo + + call xdrfint(ixdrf, ndowna(0,il), iret) + do i=1,ndowna(0,il) + call xdrfint(ixdrf, ndowna(i,il), iret) + enddo + enddo + do il=1,nodes + do j=1,4 + call xdrffloat(ixdrf, t_restart1(j,il), iret) + enddo + enddo +#endif + endif + call mpi_scatter(t_restart1,5,mpi_real,& + t5_restart1,5,mpi_real,king,CG_COMM,ierr) + totT=t5_restart1(1) + EK=t5_restart1(2) + potE=t5_restart1(3) + t_bath=t5_restart1(4) + + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres +! read(irest2,'(3e15.5)') +! & (d_restart1(j,i+2*nres*il),j=1,3) + do j=1,3 +#ifdef AIX + call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) +#else + call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) +#endif + enddo + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real,& + r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + + do i=1,2*nres + do j=1,3 + d_t(j,i)=r_d(j,i) + enddo + enddo + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres +! read(irest2,'(3e15.5)') +! & (d_restart1(j,i+2*nres*il),j=1,3) + do j=1,3 +#ifdef AIX + call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) +#else + call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) +#endif + enddo + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real,& + r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + do i=1,2*nres + do j=1,3 + dc(j,i)=r_d(j,i) + enddo + enddo + + + if(usampl) then +#ifdef AIX + if(me.eq.king)then + call xdrfint_(ixdrf, nset, iret) + do i=1,nset + call xdrfint_(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint_(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + call xdrfint_(ixdrf,itmp, iret) + i_index(i,j,il,il1)=itmp + enddo + enddo + enddo + enddo + endif +#else + if(me.eq.king)then + call xdrfint(ixdrf, nset, iret) + do i=1,nset + call xdrfint(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + call xdrfint(ixdrf,itmp, iret) + i_index(i,j,il,il1)=itmp + enddo + enddo + enddo + enddo + endif +#endif + call mpi_scatter(i2set,1,mpi_integer,& + iset,1,mpi_integer,king,& + CG_COMM,ierr) + + endif + + if(me.eq.king) close(irest2) + return + end subroutine read1restart +!----------------------------------------------------------------------------- + subroutine read1restart_old + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.SBRIDGE' +! include 'COMMON.INTERACT' +!el real(kind=4) :: d_restart1(3,2*nres*maxprocs) + real(kind=4) :: r_d(3,2*nres),t5_restart1(5) +!el common /przechowalnia/ d_restart1 + + integer :: i,j,il,ierr + + if(me.eq.king)then + open(irest2,file=mremd_rst_name,status='unknown') + read (irest2,*) (i2rep(i),i=0,nodes-1) + read (irest2,*) (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) + read (irest2,*) ndowna(0,il),& + (ndowna(i,il),i=1,ndowna(0,il)) + enddo + do il=1,nodes + read(irest2,*) (t_restart1(j,il),j=1,4) + enddo + endif + call mpi_scatter(t_restart1,5,mpi_real,& + t5_restart1,5,mpi_real,king,CG_COMM,ierr) + totT=t5_restart1(1) + EK=t5_restart1(2) + potE=t5_restart1(3) + t_bath=t5_restart1(4) + + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres + read(irest2,'(3e15.5)') & + (d_restart1(j,i+2*nres*il),j=1,3) + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real,& + r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + + do i=1,2*nres + do j=1,3 + d_t(j,i)=r_d(j,i) + enddo + enddo + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres + read(irest2,'(3e15.5)') & + (d_restart1(j,i+2*nres*il),j=1,3) + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real,& + r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + do i=1,2*nres + do j=1,3 + dc(j,i)=r_d(j,i) + enddo + enddo + if(me.eq.king) close(irest2) + return + end subroutine read1restart_old +!---------------------------------------------------------------- + subroutine alloc_MREMD_arrays + +! if(.not.allocated(mset)) allocate(mset(max0(nset,1))) + if(.not.allocated(stdfsc)) allocate(stdfsc(ntyp1)) !(ntyp1)) +! commom.remd +! common /remdcommon/ in io: read_REMDpar +! real(kind=8),dimension(:),allocatable :: remd_t !(maxprocs) +! integer,dimension(:),allocatable :: remd_m !(maxprocs) +! common /remdrestart/ + if(.not.allocated(i2rep)) allocate(i2rep(0:2*nodes)) + + allocate(i2set(0:2*nodes)) !(0:maxprocs) + allocate(ifirst(0:nodes)) !(maxprocs) + allocate(nupa(0:nodes,0:2*nodes)) + allocate(ndowna(0:nodes,0:2*nodes)) !(0:maxprocs/4,0:maxprocs) + allocate(t_restart1(5,nodes)) !(5,maxprocs) + allocate(iset_restart1(nodes)) !(maxprocs) +! common /traj1cache/ + allocate(totT_cache(max_cache_traj),EK_cache(max_cache_traj)) + allocate(potE_cache(max_cache_traj),t_bath_cache(max_cache_traj)) + allocate(Uconst_cache(max_cache_traj)) !(max_cache_traj) + allocate(qfrag_cache(nfrag,max_cache_traj)) !(50,max_cache_traj) + allocate(qpair_cache(npair,max_cache_traj)) !(100,max_cache_traj) + allocate(ugamma_cache(nfrag_back,max_cache_traj)) + allocate(utheta_cache(nfrag_back,max_cache_traj)) + allocate(uscdiff_cache(nfrag_back,max_cache_traj)) !(maxfrag_back,max_cache_traj) + allocate(c_cache(3,2*nres+2,max_cache_traj)) !(3,maxres2+2,max_cache_traj) + allocate(iset_cache(max_cache_traj)) !(max_cache_traj) + + return + end subroutine alloc_MREMD_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module MREMDyn diff --git a/source/unres/MREMD.f90 b/source/unres/MREMD.f90 deleted file mode 100644 index 92a1178..0000000 --- a/source/unres/MREMD.f90 +++ /dev/null @@ -1,2024 +0,0 @@ - module MREMDyn -!----------------------------------------------------------------------------- - use io_units - use names - use MPI_data - use md_data - use remd_data - use geometry_data - use energy_data - use control_data, only:maxprocs - use MDyn - - implicit none -!----------------------------------------------------------------------------- -! commom.remd -! common /remdrestart/ - integer(kind=2),dimension(:),allocatable :: i2set !(0:maxprocs) - integer(kind=2),dimension(:),allocatable :: ifirst !(maxprocs) - integer(kind=2),dimension(:,:),allocatable :: nupa,& - ndowna !(0:maxprocs/4,0:maxprocs) - real(kind=4),dimension(:,:),allocatable :: t_restart1 !(5,maxprocs) - integer,dimension(:),allocatable :: iset_restart1 !(maxprocs) -! common /traj1cache/ - real(kind=4),dimension(:),allocatable :: totT_cache,EK_cache,& - potE_cache,t_bath_cache,Uconst_cache !(max_cache_traj) - real(kind=4),dimension(:,:),allocatable :: qfrag_cache !(50,max_cache_traj) - real(kind=4),dimension(:,:),allocatable :: qpair_cache !(100,max_cache_traj) - real(kind=4),dimension(:,:),allocatable :: ugamma_cache,& - utheta_cache,uscdiff_cache !(maxfrag_back,max_cache_traj) - real(kind=4),dimension(:,:,:),allocatable :: c_cache !(3,maxres2+2,max_cache_traj) - integer :: ntwx_cache,ii_write !,max_cache_traj_use - integer,dimension(:),allocatable :: iset_cache !(max_cache_traj) -!----------------------------------------------------------------------------- -! common /przechowalnia/ - real(kind=4),dimension(:,:),allocatable :: d_restart1 !(3,2*nres*maxprocs) - real(kind=4),dimension(:,:),allocatable :: d_restart2 !(3,2*nres*maxprocs) - real(kind=4),dimension(:,:),allocatable :: p_c !(3,(nres2+2)*maxprocs) -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- -! MREMD.F -!----------------------------------------------------------------------------- - - subroutine MREMD - - use comm_gucio - use control, only:tcpu,ovrtim - use io_base, only:ilen - use control_data - use geometry_data - use random, only: iran_num,ran_number - use compare, only:hairpin,secondary2 - use io, only:cartout,statout -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.MUCA' -! include 'COMMON.HAIRPIN' - integer :: ERRCODE - real(kind=8),dimension(3) :: L,vcm - real(kind=8) :: energia(0:n_ene) - real(kind=8) :: remd_t_bath(maxprocs) - integer :: iremd_iset(maxprocs) - integer(kind=2) :: i_index(maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - real(kind=8) :: remd_ene(0:n_ene+4,maxprocs) - integer :: iremd_acc(maxprocs),iremd_tot(maxprocs) - integer :: iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs) - integer :: rstcount !el ilen, -!el external ilen - character(len=50) :: tytul -!el common /gucio/ cm - integer :: itime -!old integer nup(0:maxprocs),ndown(0:maxprocs) - integer :: rep2i(0:maxprocs),ireqi(maxprocs) - integer :: icache_all(maxprocs) - integer :: status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) - logical :: synflag, end_of_run, file_exist = .false.!, ovrtim - - real(kind=8) :: delta,time00,time01,time001,time02,time03,time04,& - time05,time06,time07,time08,tt0,scalfac,ene_iex_iex,& - ene_i_i,ene_iex_i,ene_i_iex,xxx,tmp,econstr_temp_i,& - econstr_temp_iex - integer :: k,il,il1,i,j,nharp,ii,ierr,itime_master,irr,iex,& - i_set_temp,itmp,i_temp,i_mult,i_iset,i_mset,i_dir,i_temp1,& - i_mult1,i_iset1,i_mset1,ierror - integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) -!deb imin_itime_old=0 - integer :: nres2 !el - nres2=2*nres - time001=0.0d0 - - ntwx_cache=0 - time00=MPI_WTIME() - time01=time00 - if(me.eq.king.or..not.out1file) then - write (iout,*) 'MREMD',nodes,'time before',time00-walltime - write (iout,*) "NREP=",nrep - endif - - synflag=.false. - if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst") - endif - mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" - -!d print *,'MREMD',nodes -!d print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) -!de write (iout,*) "Start MREMD: me",me," t_bath",t_bath - k=0 - rep2i(k)=-1 - do il=1,max0(nset,1) - do il1=1,max0(mset(il),1) - do i=1,nrep - iremd_acc(i)=0 - iremd_acc_usa(i)=0 - iremd_tot(i)=0 - do j=1,remd_m(i) - i2rep(k)=i - i2set(k)=il - rep2i(i)=k - k=k+1 - i_index(i,j,il,il1)=k - enddo - enddo - enddo - enddo - - if(me.eq.king.or..not.out1file) then - write(iout,*) (i2rep(i),i=0,nodes-1) - write(iout,*) (i2set(i),i=0,nodes-1) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - -! print *,'i2rep',me,i2rep(me) -! print *,'rep2i',(rep2i(i),i=0,nrep) - -!old if (i2rep(me).eq.nrep) then -!old nup(0)=0 -!old else -!old nup(0)=remd_m(i2rep(me)+1) -!old k=rep2i(int(i2rep(me)))+1 -!old do i=1,nup(0) -!old nup(i)=k -!old k=k+1 -!old enddo -!old endif - -!d print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) - -!old if (i2rep(me).eq.1) then -!old ndown(0)=0 -!old else -!old ndown(0)=remd_m(i2rep(me)-1) -!old k=rep2i(i2rep(me)-2)+1 -!old do i=1,ndown(0) -!old ndown(i)=k -!old k=k+1 -!old enddo -!old endif - -!d print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) - -!el common /przechowalnia/ - if(.not.allocated(d_restart1)) allocate(d_restart1(3,nres2*nodes)) - if(.not.allocated(d_restart2)) allocate(d_restart2(3,nres2*nodes)) - if(.not.allocated(p_c)) allocate(p_c(3,(nres2+2)*nodes)) -!el------------- - - write (*,*) "Processor",me," rest",rest,& - "restart1fie",restart1file - if(rest.and.restart1file) then - if (me.eq.king) & - inquire(file=mremd_rst_name,exist=file_exist) -!d write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,& - IERR) -!d write (*,*) me," After broadcast: file_exist",file_exist - if(file_exist) then - if(me.eq.king.or..not.out1file) & - write (iout,*) 'Master is reading restart1file' - call read1restart(i_index) - else - if(me.eq.king.or..not.out1file) & - write (iout,*) 'WARNING : no restart1file' - endif - - if(me.eq.king.or..not.out1file) then - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - endif - - if(me.eq.king) then - if (rest.and..not.restart1file) & - inquire(file=mremd_rst_name,exist=file_exist) - if(.not.file_exist.and.rest.and..not.restart1file) & - write(iout,*) 'WARNING : no restart file',mremd_rst_name - IF (rest.and.file_exist.and..not.restart1file) THEN - write (iout,*) 'Master is reading restart file',& - mremd_rst_name - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) - read (irest2,*) ndowna(0,il),& - (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl) then - read (irest2,*) - read (irest2,*) nset - read (irest2,*) - read (irest2,*) (mset(i),i=1,nset) - read (irest2,*) - read (irest2,*) (i2set(i),i=0,nodes-1) - read (irest2,*) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - - close(irest2) - - write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) - write (iout,'(a6,1000i5)') "ifirst",& - (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":",& - (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":",& - (ndowna(i,il),i=1,ndowna(0,il)) - enddo - ELSE IF (.not.(rest.and.file_exist)) THEN - do il=1,remd_m(1) - ifirst(il)=il - enddo - - do il=1,nodes - if (i2rep(il-1).eq.nrep) then - nupa(0,il)=0 - else - nupa(0,il)=remd_m(i2rep(il-1)+1) - k=rep2i(int(i2rep(il-1)))+1 - do i=1,nupa(0,il) - nupa(i,il)=k+1 - k=k+1 - enddo - endif - if (i2rep(il-1).eq.1) then - ndowna(0,il)=0 - else - ndowna(0,il)=remd_m(i2rep(il-1)-1) - k=rep2i(i2rep(il-1)-2)+1 - do i=1,ndowna(0,il) - ndowna(i,il)=k+1 - k=k+1 - enddo - endif - enddo - - write (iout,'(a6,100i4)') "ifirst",& - (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":",& - (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":",& - (ndowna(i,il),i=1,ndowna(0,il)) - enddo - - ENDIF - endif -! -! t_bath=retmin+(retmax-retmin)*me/(nodes-1) - if(.not.(rest.and.file_exist.and.restart1file)) then - if (me .eq. king) then - t_bath=retmin - else - t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) - endif -!d print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) - if (remd_tlist) t_bath=remd_t(int(i2rep(me))) - - endif - if(usampl) then - iset=i2set(me) - if(me.eq.king.or..not.out1file) & - write(iout,*) me,"iset=",iset,"t_bath=",t_bath - endif -! - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -! print *,'irep',me,t_bath - if (.not.rest) then - if (me.eq.king .or. .not. out1file) & - write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath - call rescale_weights(t_bath) - endif - - -!------copy MD-------------- -! The driver for molecular dynamics subroutines -!------------------------------------------------ - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - if(me.eq.king.or..not.out1file) & - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -! Determine the inverse of the inertia matrix. - call setup_MD_matrices -! Initialize MD - call init_MD - if (rest) then - if (me.eq.king .or. .not. out1file) & - write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - call rescale_weights(t_bath) - endif - -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -! Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) & - "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - time00=MPI_WTIME() - if (me.eq.king .or. .not. out1file) & - write(iout,*) 'Setup time',time00-walltime - call flush(iout) -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - itime=0 - end_of_run=.false. - - do while(.not.end_of_run) - itime=itime+1 - if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. - if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. & - mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') & - "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 & - .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - if (me.eq.king .or. .not. out1file) & - write(iout,'(a,f20.2)') & - "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) -!d write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -! Time-reversible RESPA algorithm -! (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -! Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if(ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) - endif - if (mod(itime,ntwx).eq.0.and..not.traj1file) then - write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath - if(mdpdb) then - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (mod(itime,ntwx).eq.0.and.traj1file) then - if(ntwx_cache.lt.max_cache_traj_use) then - ntwx_cache=ntwx_cache+1 - else - if (max_cache_traj_use.ne.1) & - print *,itime,"processor ",me," over cache ",ntwx_cache - do i=1,ntwx_cache-1 - - totT_cache(i)=totT_cache(i+1) - EK_cache(i)=EK_cache(i+1) - potE_cache(i)=potE_cache(i+1) - t_bath_cache(i)=t_bath_cache(i+1) - Uconst_cache(i)=Uconst_cache(i+1) - iset_cache(i)=iset_cache(i+1) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,i+1) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,i+1) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,i+1) - ugamma_cache(ii,i)=ugamma_cache(ii,i+1) - uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1) - enddo - - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,i+1) - enddo - enddo - enddo - endif - - totT_cache(ntwx_cache)=totT - EK_cache(ntwx_cache)=EK - potE_cache(ntwx_cache)=potE - t_bath_cache(ntwx_cache)=t_bath - Uconst_cache(ntwx_cache)=Uconst - iset_cache(ntwx_cache)=iset - - do i=1,nfrag - qfrag_cache(i,ntwx_cache)=qfrag(i) - enddo - do i=1,npair - qpair_cache(i,ntwx_cache)=qpair(i) - enddo - do i=1,nfrag_back - utheta_cache(i,ntwx_cache)=utheta(i) - ugamma_cache(i,ntwx_cache)=ugamma(i) - uscdiff_cache(i,ntwx_cache)=uscdiff(i) - enddo - - do i=1,nres*2 - do j=1,3 - c_cache(j,i,ntwx_cache)=c(j,i) - enddo - enddo - - endif - if ((rstcount.eq.1000.or.itime.eq.n_timestep) & - .and..not.restart1file) then - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) "i2rep" - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) "ifirst" - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) "nupa",il - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) "ndowna",il - write (irest1,*) ndowna(0,il),& - (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl) then - write (irest1,*) "nset" - write (irest1,*) nset - write (irest1,*) "mset" - write (irest1,*) (mset(i),i=1,nset) - write (irest1,*) "i2set" - write (irest1,*) (i2set(i),i=0,nodes-1) - write (irest1,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - endif - close(irest1) - endif - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl) then - write (irest2,*) iset - endif - close(irest2) - rstcount=0 - endif - -! REMD - exchange -! forced synchronization - if (mod(itime,i_sync_step).eq.0 .and. me.ne.king & - .and. .not. mremdsync) then - synflag=.false. - call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) - if (synflag) then - call mpi_recv(itime_master, 1, MPI_INTEGER,& - 0,101,CG_COMM, status, ierr) - call mpi_barrier(CG_COMM, ierr) -!deb if (out1file.or.traj1file) then -!deb call mpi_gather(itime,1,mpi_integer, -!deb & icache_all,1,mpi_integer,king, -!deb & CG_COMM,ierr) - if(traj1file) & - call mpi_gather(ntwx_cache,1,mpi_integer,& - icache_all,1,mpi_integer,king,& - CG_COMM,ierr) - if (.not.out1file) & - write(iout,*) 'REMD synchro at',itime_master,itime - if (itime_master.ge.n_timestep .or. ovrtim()) & - end_of_run=.true. -!time call flush(iout) - endif - endif - -! REMD - exchange - if ((mod(itime,nstex).eq.0.and.me.eq.king & - .or.end_of_run.and.me.eq.king ) & - .and. .not. mremdsync ) then - synflag=.true. - do i=1,nodes-1 - call mpi_isend(itime,1,MPI_INTEGER,i,101, & - CG_COMM, ireqi(i), ierr) -!d write(iout,*) 'REMD synchro with',i -!d call flush(iout) - enddo - call mpi_waitall(nodes-1,ireqi,statusi,ierr) - call mpi_barrier(CG_COMM, ierr) - time01=MPI_WTIME() - write(iout,*) 'REMD synchro at',itime,'time=',time01-time00 - if (out1file.or.traj1file) then -!deb call mpi_gather(itime,1,mpi_integer, -!deb & itime_all,1,mpi_integer,king, -!deb & CG_COMM,ierr) -!deb write(iout,'(a19,8000i8)') ' REMD synchro itime', -!deb & (itime_all(i),i=1,nodes) - if(traj1file) then -!deb imin_itime=itime_all(1) -!deb do i=2,nodes -!deb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) -!deb enddo -!deb ii_write=(imin_itime-imin_itime_old)/ntwx -!deb imin_itime_old=int(imin_itime/ntwx)*ntwx -!deb write(iout,*) imin_itime,imin_itime_old,ii_write - call mpi_gather(ntwx_cache,1,mpi_integer,& - icache_all,1,mpi_integer,king,& - CG_COMM,ierr) -! write(iout,'(a19,8000i8)') ' ntwx_cache', -! & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo -! write(iout,*) "MIN ii_write=",ii_write - endif - endif -!time call flush(iout) - endif - if(mremdsync .and. mod(itime,nstex).eq.0) then - synflag=.true. - if (me.eq.king .or. .not. out1file) & - write(iout,*) 'REMD synchro at',itime - - if(traj1file) then - call mpi_gather(ntwx_cache,1,mpi_integer,& - icache_all,1,mpi_integer,king,& - CG_COMM,ierr) - if (me.eq.king) then - write(iout,'(a19,8000i8)') ' ntwx_cache',& - (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo - write(iout,*) "MIN ii_write=",ii_write - endif - endif - call flush(iout) - endif - if (synflag) then -! Update the time safety limiy - if (time001-time00.gt.safety) then - safety=time001-time00+600 - write (iout,*) "****** SAFETY increased to",safety," s" - endif - if (ovrtim()) end_of_run=.true. - endif - if(synflag.and..not.end_of_run) then - time02=MPI_WTIME() - synflag=.false. - - write(iout,*) 'REMD before',me,t_bath - -! call mpi_gather(t_bath,1,mpi_double_precision, -! & remd_t_bath,1,mpi_double_precision,king, -! & CG_COMM,ierr) - potEcomp(n_ene+1)=t_bath - if (usampl) then - potEcomp(n_ene+2)=iset - if (iset.lt.nset) then - i_set_temp=iset - iset=iset+1 - call EconstrQ - potEcomp(n_ene+3)=Uconst - iset=i_set_temp - endif - if (iset.gt.1) then - i_set_temp=iset - iset=iset-1 - call EconstrQ - potEcomp(n_ene+4)=Uconst - iset=i_set_temp - endif - endif - call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision,& - remd_ene(0,1),n_ene+5,mpi_double_precision,king,& - CG_COMM,ierr) - if(lmuca) then - call mpi_gather(elow,1,mpi_double_precision,& - elowi,1,mpi_double_precision,king,& - CG_COMM,ierr) - call mpi_gather(ehigh,1,mpi_double_precision,& - ehighi,1,mpi_double_precision,king,& - CG_COMM,ierr) - endif - - time03=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD gather times=',time03-time01 & - ,time03-time02 - endif - - if (restart1file) call write1rst(i_index) - - time04=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing rst time=',time04-time03 - endif - - if (traj1file) call write1traj -!d debugging -!deb call mpi_gather(ntwx_cache,1,mpi_integer, -!deb & icache_all,1,mpi_integer,king, -!deb & CG_COMM,ierr) -!deb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file', -!deb & (icache_all(i),i=1,nodes) -!d end - - - time05=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing traj time=',time05-time04 - call flush(iout) - endif - - - if (me.eq.king) then - do i=1,nodes - remd_t_bath(i)=remd_ene(n_ene+1,i) - iremd_iset(i)=remd_ene(n_ene+2,i) - enddo -#ifdef DEBUG - if(lmuca) then -!o write(iout,*) 'REMD exchange temp,ene,elow,ehigh' - do i=1,nodes - write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i),& - elowi(i),ehighi(i) - enddo - else - write(iout,*) 'REMD exchange temp,ene' - do i=1,nodes - write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) - write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) - enddo - endif -#endif -!------------------------------------- - IF(.not.usampl) THEN - write (iout,*) "Enter exchnge, remd_m",remd_m(1),& - " nodes",nodes - call flush(iout) - write (iout,*) "remd_m(1)",remd_m(1) - do irr=1,remd_m(1) - i=ifirst(iran_num(1,remd_m(1))) - write (iout,*) "i",i - call flush(iout) - - do ii=1,nodes-1 - -#ifdef DEBUG - write (iout,*) "i",i," nupa(0,i)",int(nupa(0,i)) -#endif - if(i.gt.0.and.nupa(0,i).gt.0) then - iex=i -! if (i.eq.1 .and. int(nupa(0,i)).eq.1) then -! write (iout,*) -! & "CHUJ ABSOLUTNY!!! No way to sample a distinct replica in MREMD" -! call flush(iout) -! call MPI_Abort(MPI_COMM_WORLD,ERRCODE,ierr) -! endif -! do while (iex.eq.i) -! write (iout,*) "upper",nupa(int(nupa(0,i)),i) - iex=nupa(iran_num(1,int(nupa(0,i))),i) -! enddo -! write (iout,*) "nupa(0,i)",nupa(0,i)," iex",iex - if (lmuca) then - call muca_delta(remd_t_bath,remd_ene,i,iex,delta) - else -! Swap temperatures between conformations i and iex with recalculating the free energies -! following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -! write (iout,*) "i",i," ene_i_i",ene_i_i, -! & " iex",iex," ene_iex_iex",ene_iex_iex -! write (iout,*) "rescaling weights with temperature", -! & remd_t_bath(i) -! call flush(iout) - call rescale_weights(remd_t_bath(i)) - -! write (iout,*) "0,iex",remd_t_bath(i) -! call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -! write (iout,*) "ene_iex_i",remd_ene(0,iex) - -! write (iout,*) "0,i",remd_t_bath(i) -! call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -! write (iout,*) "ene_i_i",remd_ene(0,i) -! call flush(iout) -! write (iout,*) "rescaling weights with temperature", -! & remd_t_bath(iex) - if (real(ene_i_i).ne.real(remd_ene(0,i))) then - write (iout,*) "ERROR: inconsistent energies:",i,& - ene_i_i,remd_ene(0,i) - endif - call rescale_weights(remd_t_bath(iex)) - -! write (iout,*) "0,i",remd_t_bath(iex) -! call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -! write (iout,*) "ene_i_iex",remd_ene(0,i) -! call flush(iout) - ene_i_iex=remd_ene(0,i) - -! write (iout,*) "0,iex",remd_t_bath(iex) -! call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then - write (iout,*) "ERROR: inconsistent energies:",iex,& - ene_iex_iex,remd_ene(0,iex) - endif -! write (iout,*) "ene_iex_iex",remd_ene(0,iex) -! write (iout,*) "i",i," iex",iex -! write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -! & " ene_i_iex",ene_i_iex, -! & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex -! call flush(iout) - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- & - (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -! write(iout,*) 'delta',delta -! delta=(remd_t_bath(i)-remd_t_bath(iex))* -! & (remd_ene(i)-remd_ene(iex))/Rb/ -! & (remd_t_bath(i)*remd_t_bath(iex)) - endif - if (delta .gt. 50.0d0) then - delta=0.0d0 - else -#ifdef OSF - if(isnan(delta))then - delta=0.0d0 - else if (delta.lt.-50.0d0) then - delta=dexp(50.0d0) - else - delta=dexp(-delta) - endif -#else - delta=dexp(-delta) -#endif - endif - iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -! write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx -! call flush(iout) - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - if(lmuca) then - tmp=elowi(i) - elowi(i)=elowi(iex) - elowi(iex)=tmp - tmp=ehighi(i) - ehighi(i)=ehighi(iex) - ehighi(iex)=tmp - endif - - - do k=0,nodes - itmp=nupa(k,i) - nupa(k,i)=nupa(k,iex) - nupa(k,iex)=itmp - itmp=ndowna(k,i) - ndowna(k,i)=ndowna(k,iex) - ndowna(k,iex)=itmp - enddo - do il=1,nodes - if (ifirst(il).eq.i) ifirst(il)=iex - do k=1,nupa(0,il) - if (nupa(k,il).eq.i) then - nupa(k,il)=iex - elseif (nupa(k,il).eq.iex) then - nupa(k,il)=i - endif - enddo - do k=1,ndowna(0,il) - if (ndowna(k,il).eq.i) then - ndowna(k,il)=iex - elseif (ndowna(k,il).eq.iex) then - ndowna(k,il)=i - endif - enddo - enddo - - iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - -! write(iout,*) 'exchange',i,iex -! write (iout,'(a8,100i4)') "@ ifirst", -! & (ifirst(k),k=1,remd_m(1)) -! do il=1,nodes -! write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", -! & (nupa(k,il),k=1,nupa(0,il)) -! write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", -! & (ndowna(k,il),k=1,ndowna(0,il)) -! enddo -! call flush(iout) - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - i=iex - endif - endif - enddo - enddo -!d write (iout,*) "exchange completed" -!d call flush(iout) - ELSE - do ii=1,nodes -!d write(iout,*) "########",ii - - i_temp=iran_num(1,nrep) - i_mult=iran_num(1,remd_m(i_temp)) - i_iset=iran_num(1,nset) - i_mset=iran_num(1,mset(i_iset)) - i=i_index(i_temp,i_mult,i_iset,i_mset) - -!d write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset - - i_dir=iran_num(1,3) -!d write(iout,*) "i_dir=",i_dir - - if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then - - i_temp1=i_temp - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - else - goto 444 - endif - -!d write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 - call flush(iout) - -! Swap temperatures between conformations i and iex with recalculating the free energies -! following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -!o write (iout,*) "rescaling weights with temperature", -!o & remd_t_bath(i) - call rescale_weights(remd_t_bath(i)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -!d write (iout,*) "ene_iex_i",remd_ene(0,iex) -! call sum_energy(remd_ene(0,i),.false.) -!d write (iout,*) "ene_i_i",remd_ene(0,i) -! write (iout,*) "rescaling weights with temperature", -! & remd_t_bath(iex) -! if (real(ene_i_i).ne.real(remd_ene(0,i))) then -! write (iout,*) "ERROR: inconsistent energies:",i, -! & ene_i_i,remd_ene(0,i) -! endif - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i),.false.) -!d write (iout,*) "ene_i_iex",remd_ene(0,i) - ene_i_iex=remd_ene(0,i) -! call sum_energy(remd_ene(0,iex),.false.) -! if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then -! write (iout,*) "ERROR: inconsistent energies:",iex, -! & ene_iex_iex,remd_ene(0,iex) -! endif -!d write (iout,*) "ene_iex_iex",remd_ene(0,iex) -! write (iout,*) "i",i," iex",iex -!d write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -!d & " ene_i_iex",ene_i_iex, -!d & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- & - (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -!d write(iout,*) 'delta',delta -! delta=(remd_t_bath(i)-remd_t_bath(iex))* -! & (remd_ene(i)-remd_ene(iex))/Rb/ -! & (remd_t_bath(i)*remd_t_bath(iex)) - if (delta .gt. 50.0d0) then - delta=0.0d0 - else - delta=dexp(-delta) - endif - if (i_dir.eq.1.or.i_dir.eq.3) & - iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - if (i_dir.eq.2.or.i_dir.eq.3) & - iremd_tot_usa(int(i2set(i-1)))= & - iremd_tot_usa(int(i2set(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -!d write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - - itmp=iremd_iset(i) - iremd_iset(i)=iremd_iset(iex) - iremd_iset(iex)=itmp - - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - - if (i_dir.eq.1.or.i_dir.eq.3) & - iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - - if (i_dir.eq.2.or.i_dir.eq.3) & - iremd_acc_usa(int(i2set(i-1)))= & - iremd_acc_usa(int(i2set(i-1)))+1 - - itmp=i2set(i-1) - i2set(i-1)=i2set(iex-1) - i2set(iex-1)=itmp - - itmp=i_index(i_temp,i_mult,i_iset,i_mset) - i_index(i_temp,i_mult,i_iset,i_mset)= & - i_index(i_temp1,i_mult1,i_iset1,i_mset1) - i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - remd_ene(20,iex)=econstr_temp_iex - remd_ene(20,i)=econstr_temp_i - endif - -!d do il=1,nset -!d do il1=1,mset(il) -!d do i=1,nrep -!d do j=1,remd_m(i) -!d write(iout,*) i,j,il,il1,i_index(i,j,il,il1) -!d enddo -!d enddo -!d enddo -!d enddo - - 444 continue - - enddo - - - ENDIF - -!------------------------------------- - write (iout,*) "NREP",nrep - do i=1,nrep - if(iremd_tot(i).ne.0) & - write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i) & - ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i) - enddo - - if(usampl) then - do i=1,nset - if(iremd_tot_usa(i).ne.0) & - write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i,& - iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) - enddo - endif - - call flush(iout) - -!d write (iout,'(a6,100i4)') "ifirst", -!d & (ifirst(i),i=1,remd_m(1)) -!d do il=1,nodes -!d write (iout,'(a5,i4,a1,100i4)') "nup",il,":", -!d & (nupa(i,il),i=1,nupa(0,il)) -!d write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", -!d & (ndowna(i,il),i=1,ndowna(0,il)) -!d enddo - endif - - time06=MPI_WTIME() -!d write (iout,*) "Before scatter" -!d call flush(iout) -#ifdef DEBUG - if (me.eq.king) then - write (iout,*) "t_bath before scatter",remd_t_bath - call flush(iout) - endif -#endif - call mpi_scatter(remd_t_bath,1,mpi_double_precision,& - t_bath,1,mpi_double_precision,king,& - CG_COMM,ierr) -!d write (iout,*) "After scatter" -!d call flush(iout) - if(usampl) & - call mpi_scatter(iremd_iset,1,mpi_integer,& - iset,1,mpi_integer,king,& - CG_COMM,ierr) - - time07=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD scatter time=',time07-time06 - endif - - if(lmuca) then - call mpi_scatter(elowi,1,mpi_double_precision,& - elow,1,mpi_double_precision,king,& - CG_COMM,ierr) - call mpi_scatter(ehighi,1,mpi_double_precision,& - ehigh,1,mpi_double_precision,king,& - CG_COMM,ierr) - endif - call rescale_weights(t_bath) -!o write (iout,*) "Processor",me, -!o & " rescaling weights with temperature",t_bath - - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -!de write(iout,*) 'REMD after',me,t_bath - time08=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD exchange time 8-0=',time08-time00 - write(iout,*) 'REMD exchange time 8-7=',time08-time07 - write(iout,*) 'REMD exchange time 7-6=',time07-time06 - write(iout,*) 'REMD exchange time 6-5=',time06-time05 - write(iout,*) 'REMD exchange time 5-4=',time05-time04 - write(iout,*) 'REMD exchange time 4-3=',time04-time03 - write(iout,*) 'REMD exchange time 3-2=',time03-time02 - write(iout,*) 'REMD exchange time 2-1=',time02-time01 - write(iout,*) 'REMD exchange time 1-0=',time01-time00 - call flush(iout) - endif - endif - enddo - - if (restart1file) then - if (me.eq.king .or. .not. out1file) & - write(iout,*) 'writing restart at the end of run' - call write1rst(i_index) - endif - - if (traj1file) call write1traj -!d debugging -!deb call mpi_gather(ntwx_cache,1,mpi_integer, -!deb & icache_all,1,mpi_integer,king, -!deb & CG_COMM,ierr) -!deb write(iout,'(a40,8000i8)') -!deb & ' ntwx_cache after traj1file at the end', -!deb & (icache_all(i),i=1,nodes) -!d end - - -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - if (me.eq.king .or. .not. out1file) then - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') & - ' Timing ',& - 'MD calculations setup:',t_MDsetup,& - 'Energy & gradient evaluation:',t_enegrad,& - 'Stochastic MD setup:',t_langsetup,& - 'Stochastic MD step setup:',t_sdsetup,& - 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') & - ' End of MD calculation ' - endif -!el common /przechowalnia/ -! deallocate(d_restart1) -! deallocate(d_restart2) -! deallocate(p_c) -!el-------------- - return - end subroutine MREMD -!----------------------------------------------------------------------------- - subroutine write1rst(i_index) - - use control_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.SBRIDGE' -! include 'COMMON.INTERACT' - -!el real(kind=4) :: d_restart1(3,2*nres*maxprocs),& -!el d_restart2(3,2*nres*maxprocs) - real(kind=4) :: r_d(3,2*nres) - real(kind=4) :: t5_restart1(5) - integer :: iret,itmp - integer(kind=2) :: i_index(maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) -!el common /przechowalnia/ d_restart1,d_restart2 - integer :: i,j,il,il1,ierr,ixdrf - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real,& - t_restart1,5,mpi_real,king,CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real,& - d_restart1,3*2*nres,mpi_real,king,& - CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real,& - d_restart2,3*2*nres,mpi_real,king,& - CG_COMM,ierr) - - if(me.eq.king) then -#ifdef AIX - call xdrfopen_(ixdrf,mremd_rst_name, "w", iret) - do i=0,nodes-1 - call xdrfint_(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint_(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - do i=0,nupa(0,il) - call xdrfint_(ixdrf, nupa(i,il), iret) - enddo - - do i=0,ndowna(0,il) - call xdrfint_(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes - do j=1,4 - call xdrffloat_(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat_(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - if(usampl) then - call xdrfint_(ixdrf, nset, iret) - do i=1,nset - call xdrfint_(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint_(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint_(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - call xdrfclose_(ixdrf, iret) -#else - call xdrfopen(ixdrf,mremd_rst_name, "w", iret) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - do i=0,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - - do i=0,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - - if(usampl) then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - call xdrfclose(ixdrf, iret) -#endif - endif - return - end subroutine write1rst -!----------------------------------------------------------------------------- - subroutine write1traj - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.SBRIDGE' -! include 'COMMON.INTERACT' - - real(kind=4) :: t5_restart1(5) - integer :: iret,itmp - real(kind=4) :: xcoord(3,2*nres+2),prec - real(kind=4) :: r_qfrag(50),r_qpair(100) - real(kind=4) :: r_utheta(50),r_ugamma(100),r_uscdiff(100) - real(kind=4) :: p_qfrag(50*maxprocs),p_qpair(100*maxprocs) - real(kind=4) :: p_utheta(50*maxprocs),p_ugamma(100*maxprocs),& - p_uscdiff(100*maxprocs) -!el real(kind=4) :: p_c(3,(nres2+2)*maxprocs) - real(kind=4) :: r_c(3,2*nres+2) -!el common /przechowalnia/ p_c - - integer :: i,j,il,ierr,ii,ixdrf - - call mpi_bcast(ii_write,1,mpi_integer,& - king,CG_COMM,ierr) - -! debugging - print *,'traj1file',me,ii_write,ntwx_cache -! end debugging - -#ifdef AIX - if(me.eq.king) call xdrfopen_(ixdrf,cartname, "a", iret) -#else - if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) -#endif - do ii=1,ii_write -! write (iout,*) "before gather write1traj: from node",ii -! call flush(iout) -! write (iout,*) totT_cache(ii),EK_cache(ii),potE_cache(ii),t_bath_cache(ii),Uconst_cache(ii) -! call flush(iout) - t5_restart1(1)=totT_cache(ii) - t5_restart1(2)=EK_cache(ii) - t5_restart1(3)=potE_cache(ii) - t5_restart1(4)=t_bath_cache(ii) - t5_restart1(5)=Uconst_cache(ii) -! write (iout,*) "before gather write1traj: from node",ii,t5_restart1(1),t5_restart1(3),t5_restart1(5),t5_restart1(4) - call flush(iout) - call mpi_gather(t5_restart1,5,mpi_real,& - t_restart1,5,mpi_real,king,CG_COMM,ierr) -! do il=1,nodes -! write (iout,*) "after gather write1traj: from node",il,t_restart1(1,il),t_restart1(3,il),t_restart1(5,il),t_restart1(4,il) -! enddo - - call mpi_gather(iset_cache(ii),1,mpi_integer,& - iset_restart1,1,mpi_integer,king,CG_COMM,ierr) - - do i=1,nfrag - r_qfrag(i)=qfrag_cache(i,ii) - enddo - do i=1,npair - r_qpair(i)=qpair_cache(i,ii) - enddo - do i=1,nfrag_back - r_utheta(i)=utheta_cache(i,ii) - r_ugamma(i)=ugamma_cache(i,ii) - r_uscdiff(i)=uscdiff_cache(i,ii) - enddo - - call mpi_gather(r_qfrag,nfrag,mpi_real,& - p_qfrag,nfrag,mpi_real,king,& - CG_COMM,ierr) - call mpi_gather(r_qpair,npair,mpi_real,& - p_qpair,npair,mpi_real,king,& - CG_COMM,ierr) - call mpi_gather(r_utheta,nfrag_back,mpi_real,& - p_utheta,nfrag_back,mpi_real,king,& - CG_COMM,ierr) - call mpi_gather(r_ugamma,nfrag_back,mpi_real,& - p_ugamma,nfrag_back,mpi_real,king,& - CG_COMM,ierr) - call mpi_gather(r_uscdiff,nfrag_back,mpi_real,& - p_uscdiff,nfrag_back,mpi_real,king,& - CG_COMM,ierr) - -#ifdef DEBUG - write (iout,*) "p_qfrag" - do i=1,nodes - write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag) - enddo - write (iout,*) "p_qpair" - do i=1,nodes - write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair) - enddo - call flush(iout) -#endif - do i=1,nres*2 - do j=1,3 - r_c(j,i)=c_cache(j,i,ii) - enddo - enddo - - call mpi_gather(r_c,3*2*nres,mpi_real,& - p_c,3*2*nres,mpi_real,king,& - CG_COMM,ierr) - - if(me.eq.king) then -#ifdef AIX - do il=1,nodes - call xdrffloat_(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - if (dyn_ss) then - call xdrfint(ixdrf, idssb(j)+nres, iret) - call xdrfint(ixdrf, jdssb(j)+nres, iret) - else - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - endif - enddo - call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint_(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat_(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat_(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat_(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat_(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat_(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) - enddo -#else - do il=1,nodes - call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) -! write (iout,*) "write1traj: from node",ii,t_restart1(1,il),t_restart1(3,il),t_restart1(5,il),t_restart1(4,il) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - if (dyn_ss) then - call xdrfint(ixdrf, idssb(j)+nres, iret) - call xdrfint(ixdrf, jdssb(j)+nres, iret) - else - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - endif - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - enddo -#endif - endif - enddo -#ifdef AIX - if(me.eq.king) call xdrfclose_(ixdrf, iret) -#else - if(me.eq.king) call xdrfclose(ixdrf, iret) -#endif - do i=1,ntwx_cache-ii_write - - totT_cache(i)=totT_cache(ii_write+i) - EK_cache(i)=EK_cache(ii_write+i) - potE_cache(i)=potE_cache(ii_write+i) - t_bath_cache(i)=t_bath_cache(ii_write+i) - Uconst_cache(i)=Uconst_cache(ii_write+i) - iset_cache(i)=iset_cache(ii_write+i) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,ii_write+i) - ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i) - uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i) - enddo - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) - enddo - enddo - enddo - ntwx_cache=ntwx_cache-ii_write - return - end subroutine write1traj -!----------------------------------------------------------------------------- - subroutine read1restart(i_index) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.SBRIDGE' -! include 'COMMON.INTERACT' -!el real(kind=4) :: d_restart1(3,2*nres*maxprocs) - real(kind=4) :: r_d(3,2*nres),t5_restart1(5) - integer(kind=2) :: i_index(maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) -!el common /przechowalnia/ d_restart1 - integer :: i,j,il,il1,ierr,itmp,iret,ixdrf - - write (*,*) "Processor",me," called read1restart" - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read(irest2,*,err=334) i - write(iout,*) "Reading old rst in ASCI format" - close(irest2) - call read1restart_old - return - 334 continue -#ifdef AIX - call xdrfopen_(ixdrf,mremd_rst_name, "r", iret) - - do i=0,nodes-1 - call xdrfint_(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint_(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - call xdrfint_(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint_(ixdrf, nupa(i,il), iret) - enddo - - call xdrfint_(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint_(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes - do j=1,4 - call xdrffloat_(ixdrf, t_restart1(j,il), iret) - enddo - enddo -#else - call xdrfopen(ixdrf,mremd_rst_name, "r", iret) - - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - call xdrfint(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - - call xdrfint(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo -#endif - endif - call mpi_scatter(t_restart1,5,mpi_real,& - t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -! read(irest2,'(3e15.5)') -! & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 -#ifdef AIX - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) -#else - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) -#endif - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real,& - r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -! read(irest2,'(3e15.5)') -! & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 -#ifdef AIX - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) -#else - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) -#endif - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real,& - r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - - - if(usampl) then -#ifdef AIX - if(me.eq.king)then - call xdrfint_(ixdrf, nset, iret) - do i=1,nset - call xdrfint_(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint_(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint_(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif -#else - if(me.eq.king)then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif -#endif - call mpi_scatter(i2set,1,mpi_integer,& - iset,1,mpi_integer,king,& - CG_COMM,ierr) - - endif - - if(me.eq.king) close(irest2) - return - end subroutine read1restart -!----------------------------------------------------------------------------- - subroutine read1restart_old - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.SBRIDGE' -! include 'COMMON.INTERACT' -!el real(kind=4) :: d_restart1(3,2*nres*maxprocs) - real(kind=4) :: r_d(3,2*nres),t5_restart1(5) -!el common /przechowalnia/ d_restart1 - - integer :: i,j,il,ierr - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) ndowna(0,il),& - (ndowna(i,il),i=1,ndowna(0,il)) - enddo - do il=1,nodes - read(irest2,*) (t_restart1(j,il),j=1,4) - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real,& - t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') & - (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real,& - r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') & - (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real,& - r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end subroutine read1restart_old -!---------------------------------------------------------------- - subroutine alloc_MREMD_arrays - -! if(.not.allocated(mset)) allocate(mset(max0(nset,1))) - if(.not.allocated(stdfsc)) allocate(stdfsc(ntyp1)) !(ntyp1)) -! commom.remd -! common /remdcommon/ in io: read_REMDpar -! real(kind=8),dimension(:),allocatable :: remd_t !(maxprocs) -! integer,dimension(:),allocatable :: remd_m !(maxprocs) -! common /remdrestart/ - if(.not.allocated(i2rep)) allocate(i2rep(0:2*nodes)) - - allocate(i2set(0:2*nodes)) !(0:maxprocs) - allocate(ifirst(0:nodes)) !(maxprocs) - allocate(nupa(0:nodes,0:2*nodes)) - allocate(ndowna(0:nodes,0:2*nodes)) !(0:maxprocs/4,0:maxprocs) - allocate(t_restart1(5,nodes)) !(5,maxprocs) - allocate(iset_restart1(nodes)) !(maxprocs) -! common /traj1cache/ - allocate(totT_cache(max_cache_traj),EK_cache(max_cache_traj)) - allocate(potE_cache(max_cache_traj),t_bath_cache(max_cache_traj)) - allocate(Uconst_cache(max_cache_traj)) !(max_cache_traj) - allocate(qfrag_cache(nfrag,max_cache_traj)) !(50,max_cache_traj) - allocate(qpair_cache(npair,max_cache_traj)) !(100,max_cache_traj) - allocate(ugamma_cache(nfrag_back,max_cache_traj)) - allocate(utheta_cache(nfrag_back,max_cache_traj)) - allocate(uscdiff_cache(nfrag_back,max_cache_traj)) !(maxfrag_back,max_cache_traj) - allocate(c_cache(3,2*nres+2,max_cache_traj)) !(3,maxres2+2,max_cache_traj) - allocate(iset_cache(max_cache_traj)) !(max_cache_traj) - - return - end subroutine alloc_MREMD_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module MREMDyn diff --git a/source/unres/REMD.F90 b/source/unres/REMD.F90 new file mode 100644 index 0000000..edbcc8e --- /dev/null +++ b/source/unres/REMD.F90 @@ -0,0 +1,772 @@ + module REMD +!----------------------------------------------------------------------------- + use io_units + use MD_data + use REMD_data + use muca_md + + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! lagrangian_lesyng.F +!----------------------------------------------------------------------------- + subroutine lagrangian +!------------------------------------------------------------------------- +! This subroutine contains the total lagrangain from which the accelerations +! are obtained. For numerical gradient checking, the derivetive of the +! lagrangian in the velocities and coordinates are calculated seperately +!------------------------------------------------------------------------- +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use comm_cipiszcze + use energy_data + use geometry_data, only: nres + use control_data !el, only: mucadyn,lmuca +#ifdef MPI + include 'mpif.h' + real(kind=8) :: time00 +#endif +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +! include 'COMMON.MUCA' +! include 'COMMON.TIME1' + + integer :: i,j,ind,itime + real(kind=8) :: zapas(6*nres) !,muca_factor !maxres6=6*maxres + logical :: lprn = .false. +!el common /cipiszcze/ itime + itime = itt_comm + +#ifdef TIMING + time00=MPI_Wtime() +#endif + do j=1,3 + zapas(j)=-gcart(j,0) + enddo + ind=3 + if (lprn) then + write (iout,*) "Potential forces backbone" + endif + do i=nnt,nct-1 + if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') & + i,(-gcart(j,i),j=1,3) + do j=1,3 + ind=ind+1 + zapas(ind)=-gcart(j,i) + enddo + enddo + if (lprn) write (iout,*) "Potential forces sidechain" + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') & + i,(-gcart(j,i),j=1,3) + do j=1,3 + ind=ind+1 + zapas(ind)=-gxcart(j,i) + enddo + endif + enddo + + call ginv_mult(zapas,d_a_work) + + do j=1,3 + d_a(j,0)=d_a_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + d_a(j,i)=d_a_work(ind) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + ind=ind+1 + d_a(j,i+nres)=d_a_work(ind) + enddo + endif + enddo + + if(lmuca) then + imtime=imtime+1 + if(mucadyn.gt.0) call muca_update(potE) + factor=muca_factor(potE)*t_bath*Rb + +!d print *,'lmuca ',factor,potE + do j=1,3 + d_a(j,0)=d_a(j,0)*factor + enddo + do i=nnt,nct-1 + do j=1,3 + d_a(j,i)=d_a(j,i)*factor + enddo + enddo + do i=nnt,nct + do j=1,3 + d_a(j,i+nres)=d_a(j,i+nres)*factor + enddo + enddo + + endif + + if (lprn) then + write(iout,*) 'acceleration 3D' + write (iout,'(i3,3f10.5,3x,3f10.5)') 0,(d_a(j,0),j=1,3) + do i=nnt,nct-1 + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3) + enddo + do i=nnt,nct + write (iout,'(i3,3f10.5,3x,3f10.5)') & + i+nres,(d_a(j,i+nres),j=1,3) + enddo + endif +#ifdef TIMING + time_lagrangian=time_lagrangian+MPI_Wtime()-time00 +#endif + return + end subroutine lagrangian +!----------------------------------------------------------------------------- + subroutine setup_MD_matrices + + use geometry_data, only: nres,nside + use control_data + use MPI_data + use energy_data + use geometry, only:int_bounds + use md_calc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer :: ierror + real(kind=8) :: time00 +#endif +! include 'COMMON.SETUP' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' + logical :: lprn = .false. + logical :: osob + real(kind=8) :: dtdi + real(kind=8),dimension(2*nres) :: massvec,sqreig !(maxres2) maxres2=2*maxres +!el real(kind=8),dimension(:),allocatable :: Ghalf +!el real(kind=8),dimension(2*nres*(2*nres+1)/2) :: Ghalf !(mmaxres2) (mmaxres2=(maxres2*(maxres2+1)/2)) +!el real(kind=8),dimension(2*nres,2*nres) :: Gcopy !(maxres2,maxres2) +!el real(kind=8),dimension(:,:),allocatable :: Gcopy + real(kind=8),dimension(8*6*nres) :: work !(8*maxres6) + integer,dimension(6*nres) :: iwork !(maxres6) maxres6=6*maxres +!el common /przechowalnia/ Gcopy,Ghalf + real(kind=8) :: coeff + integer :: i,j,ind,ind1,k,ii,jj,m,m1,ii1,iti,nres2,ierr + nres2=2*nres + + if(.not.allocated(Gcopy)) allocate(Gcopy(nres2,nres2)) !(maxres2,maxres2) + if(.not.allocated(Ghalf)) allocate(Ghalf(nres2*(nres2+1)/2)) !mmaxres2=(maxres2*(maxres+1)/2) +! +! Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the +! inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv) +! +! Determine the number of degrees of freedom (dimen) and the number of +! sites (dimen1) + dimen=(nct-nnt+1)+nside + dimen1=(nct-nnt)+(nct-nnt+1) + dimen3=dimen*3 +#ifdef MPI + if (nfgtasks.gt.1) then + time00=MPI_Wtime() + call MPI_Bcast(5,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 + call int_bounds(dimen,igmult_start,igmult_end) + igmult_start=igmult_start-1 + call MPI_Allgather(3*igmult_start,1,MPI_INTEGER,& + ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + my_ng_count=igmult_end-igmult_start + call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1,& + MPI_INTEGER,FG_COMM,IERROR) + write (iout,*) 'Processor:',fg_rank,' CG group',kolor,& + ' absolute rank',myrank,' igmult_start',igmult_start,& + ' igmult_end',igmult_end,' count',my_ng_count + write (iout,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) + write (iout,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) + call flush(iout) + else +#endif + igmult_start=1 + igmult_end=dimen + my_ng_count=dimen +#ifdef MPI + endif +#endif +! write (iout,*) "dimen",dimen," dimen1",dimen1," dimen3",dimen3 +! Zeroing out A and fricmat + do i=1,dimen + do j=1,dimen + A(i,j)=0.0D0 + enddo + enddo +! Diagonal elements of the dC part of A and the respective friction coefficients + ind=1 + ind1=0 + do i=nnt,nct-1 + ind=ind+1 + ind1=ind1+1 + coeff=0.25d0*IP + massvec(ind1)=mp + Gmat(ind,ind)=coeff + A(ind1,ind)=0.5d0 + enddo + +! Off-diagonal elements of the dC part of A + k=3 + do i=1,nct-nnt + do j=1,i + A(i,j)=1.0d0 + enddo + enddo +! Diagonal elements of the dX part of A and the respective friction coefficients + m=nct-nnt + m1=nct-nnt+1 + ind=0 + ind1=0 + msc(ntyp1)=1.0d0 + do i=nnt,nct + ind=ind+1 + ii = ind+m + iti=itype(i) + massvec(ii)=msc(iabs(iti)) + if (iti.ne.10 .and. iti.ne.ntyp1) then + ind1=ind1+1 + ii1= ind1+m1 + A(ii,ii1)=1.0d0 + Gmat(ii1,ii1)=ISC(iabs(iti)) + endif + enddo +! Off-diagonal elements of the dX part of A + ind=0 + k=nct-nnt + do i=nnt,nct + iti=itype(i) + ind=ind+1 + do j=nnt,i + ii = ind + jj = j-nnt+1 + A(k+ii,jj)=1.0d0 + enddo + enddo + if (lprn) then + write (iout,*) + write (iout,*) "Vector massvec" + do i=1,dimen1 + write (iout,*) i,massvec(i) + enddo + write (iout,'(//a)') "A" + call matout(dimen,dimen1,nres2,nres2,A) + endif + +! Calculate the G matrix (store in Gmat) + do k=1,dimen + do i=1,dimen + dtdi=0.0d0 + do j=1,dimen1 + dtdi=dtdi+A(j,k)*A(j,i)*massvec(j) + enddo + Gmat(k,i)=Gmat(k,i)+dtdi + enddo + enddo + + if (lprn) then + write (iout,'(//a)') "Gmat" + call matout(dimen,dimen,nres2,nres2,Gmat) + endif + do i=1,dimen + do j=1,dimen + Ginv(i,j)=0.0d0 + Gcopy(i,j)=Gmat(i,j) + enddo + Ginv(i,i)=1.0d0 + enddo +! Invert the G matrix + call MATINVERT(dimen,nres2,Gcopy,Ginv,osob) + if (lprn) then + write (iout,'(//a)') "Ginv" + call matout(dimen,dimen,nres2,nres2,Ginv) + endif +#ifdef MPI + if (nfgtasks.gt.1) then + myginv_ng_count=nres2*my_ng_count + call MPI_Allgather(nres2*igmult_start,1,MPI_INTEGER,& + nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER,& + nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) + write (iout,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) + write (iout,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) + call flush(iout) +! call MPI_Scatterv(ginv(1,1),nginv_counts(0), +! & nginv_start(0),MPI_DOUBLE_PRECISION,ginv, +! & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +! call MPI_Barrier(FG_COMM,IERR) + time00=MPI_Wtime() + call MPI_Scatterv(ginv(1,1),nginv_counts(0),& + nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1),& + myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +#ifdef TIMING + time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 +#endif + do i=1,dimen + do j=1,2*my_ng_count + ginv(j,i)=gcopy(i,j) + enddo + enddo +! write (iout,*) "Master's chunk of ginv" +! call MATOUT2(my_ng_count,dimen,maxres2,maxres2,ginv) + endif +#endif + if (osob) then + write (iout,*) "The G matrix is singular." + stop + endif +! Compute G**(-1/2) and G**(1/2) + ind=0 + do i=1,dimen + do j=1,i + ind=ind+1 + Ghalf(ind)=Gmat(i,j) + enddo + enddo + call gldiag(nres2,dimen,dimen,Ghalf,work,Geigen,Gvec,& + ierr,iwork) + if (lprn) then + write (iout,'(//a)') & + "Eigenvectors and eigenvalues of the G matrix" + call eigout(dimen,dimen,nres2,nres2,Gvec,Geigen) + endif + do i=1,dimen + sqreig(i)=dsqrt(Geigen(i)) + enddo + do i=1,dimen + do j=1,dimen + Gsqrp(i,j)=0.0d0 + Gsqrm(i,j)=0.0d0 + Gcopy(i,j)=0.0d0 + do k=1,dimen + Gsqrp(i,j)=Gsqrp(i,j)+Gvec(i,k)*Gvec(j,k)*sqreig(k) + Gsqrm(i,j)=Gsqrm(i,j)+Gvec(i,k)*Gvec(j,k)/sqreig(k) + Gcopy(i,j)=Gcopy(i,j)+Gvec(i,k)*Gvec(j,k)*Geigen(k) + enddo + enddo + enddo + if (lprn) then + write (iout,*) "Comparison of original and restored G" + do i=1,dimen + do j=1,dimen + write (iout,'(2i5,5f10.5)') i,j,Gmat(i,j),Gcopy(i,j),& + Gmat(i,j)-Gcopy(i,j),Gsqrp(i,j),Gsqrm(i,j) + enddo + enddo + endif +! deallocate(Gcopy) + return + end subroutine setup_MD_matrices +!----------------------------------------------------------------------------- + subroutine EIGOUT(NC,NR,LM2,LM3,A,B) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer :: LM2,LM3,NC,NR,KA,KC,KB,I,J,N + real(kind=8) :: A(LM2,LM3),B(LM2) + KA=1 + KC=6 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,601) (B(I),I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.10) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+6 + GO TO 1 + 600 FORMAT (// 9H ROOT NO.,I4,9I11) + 601 FORMAT (/5X,10(1PE11.4)) + 602 FORMAT (2H ) + 603 FORMAT (I5,10F11.5) + 604 FORMAT (1H1) + end subroutine EIGOUT +!----------------------------------------------------------------------------- + subroutine MATOUT(NC,NR,LM2,LM3,A) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer :: LM2,LM3,NC,NR,KA,KC,KB,I,J,N + real(kind=8) :: A(LM2,LM3) + KA=1 + KC=6 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.10) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+6 + GO TO 1 + 600 FORMAT (//5x,9I11) + 602 FORMAT (2H ) + 603 FORMAT (I5,10F11.3) + 604 FORMAT (1H1) + end subroutine MATOUT +!----------------------------------------------------------------------------- + subroutine MATOUT1(NC,NR,LM2,LM3,A) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer :: LM2,LM3,NC,NR,KA,KC,KB,I,J,N + real(kind=8) :: A(LM2,LM3) + KA=1 + KC=21 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.3) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+21 + GO TO 1 + 600 FORMAT (//5x,7(3I5,2x)) + 602 FORMAT (2H ) + 603 FORMAT (I5,7(3F5.1,2x)) + 604 FORMAT (1H1) + end subroutine MATOUT1 +!----------------------------------------------------------------------------- + subroutine MATOUT2(NC,NR,LM2,LM3,A) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer :: I,J,KA,KC,KB,N + integer :: LM2,LM3,NC,NR + real(kind=8) :: A(LM2,LM3) + KA=1 + KC=12 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.3) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+12 + GO TO 1 + 600 FORMAT (//5x,4(3I9,2x)) + 602 FORMAT (2H ) + 603 FORMAT (I5,4(3F9.3,2x)) + 604 FORMAT (1H1) + end subroutine MATOUT2 +!----------------------------------------------------------------------------- + subroutine ginv_mult(z,d_a_tmp) + + use geometry_data, only: nres + use control_data + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer :: ierr,ierror +#endif +! include 'COMMON.SETUP' +! include 'COMMON.TIME1' +! include 'COMMON.MD' + real(kind=8),dimension(dimen3) :: z,z1,d_a_tmp + real(kind=8),dimension(6*nres) :: temp !(maxres6) maxres6=6*maxres + real(kind=8) :: time00,time01 + integer :: i,j,k,ind +#ifdef MPI + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then +! The matching BROADCAST for fg processors is called in ERGASTULUM + time00=MPI_Wtime() + call MPI_Bcast(4,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 +! print *,"Processor",myrank," BROADCAST iorder in GINV_MULT" + endif +! write (2,*) "time00",time00 +! write (2,*) "Before Scatterv" +! call flush(2) +! write (2,*) "Whole z (for FG master)" +! do i=1,dimen +! write (2,*) i,z(i) +! enddo +! call MPI_Barrier(FG_COMM,IERROR) + time00=MPI_Wtime() +!elwrite(iout,*) "do tej pory jest OK, MPI_Scatterv w ginv_mult" + call MPI_Scatterv(z,ng_counts(0),ng_start(0),& + MPI_DOUBLE_PRECISION,& + z1,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +! write (2,*) "My chunk of z" +! do i=1,3*my_ng_count +! write (2,*) i,z(i) +! enddo +! write (2,*) "After SCATTERV" +! call flush(2) +! write (2,*) "MPI_Wtime",MPI_Wtime() + time_scatter=time_scatter+MPI_Wtime()-time00 +#ifdef TIMING + time_scatter_ginvmult=time_scatter_ginvmult+MPI_Wtime()-time00 +#endif +! write (2,*) "time_scatter",time_scatter +! write (2,*) "dimen",dimen," dimen3",dimen3," my_ng_count", +! & my_ng_count +! call flush(2) + time01=MPI_Wtime() + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + temp(ind)=0.0d0 + do j=1,my_ng_count +! write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1, +! & Ginv(i,j),z((j-1)*3+k+1), +! & Ginv(i,j)*z((j-1)*3+k+1) +! temp(ind)=temp(ind)+Ginv(i,j)*z((j-1)*3+k+1) + temp(ind)=temp(ind)+Ginv(j,i)*z1((j-1)*3+k+1) + enddo + enddo + enddo + time_ginvmult=time_ginvmult+MPI_Wtime()-time01 +! write (2,*) "Before REDUCE" +! call flush(2) +! write (2,*) "z before reduce" +! do i=1,dimen +! write (2,*) i,temp(i) +! enddo + time00=MPI_Wtime() + call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION,& + MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +! write (2,*) "After REDUCE" +! call flush(2) + else +#endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + d_a_tmp(ind)=0.0d0 + do j=1,dimen +! write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1 +! call flush(2) +! & Ginv(i,j),z((j-1)*3+k+1), +! & Ginv(i,j)*z((j-1)*3+k+1) + d_a_tmp(ind)=d_a_tmp(ind) & + +Ginv(j,i)*z((j-1)*3+k+1) +! d_a_tmp(ind)=d_a_tmp(ind) +! & +Ginv(i,j)*z((j-1)*3+k+1) + enddo + enddo + enddo +#ifdef TIMING + time_ginvmult=time_ginvmult+MPI_Wtime()-time01 +#endif +#ifdef MPI + endif +#endif + return + end subroutine ginv_mult +!----------------------------------------------------------------------------- +#ifdef GINV_MULT + subroutine ginv_mult_test(z,d_a_tmp) + +! include 'DIMENSIONS' +!el integer :: dimen +! include 'COMMON.MD' + real(kind=8),dimension(dimen) :: z,d_a_tmp + real(kind=8),dimension(dimen/3) :: ztmp,dtmp + integer :: i,j,k,ind +! do i=1,dimen +! d_a_tmp(i)=0.0d0 +! do j=1,dimen +! d_a_tmp(i)=d_a_tmp(i)+Ginv(i,j)*z(j) +! enddo +! enddo +! +! return + +!ibm* unroll(3) + do k=0,2 + do j=1,dimen/3 + ztmp(j)=z((j-1)*3+k+1) + enddo + + call alignx(16,ztmp(1)) + call alignx(16,dtmp(1)) + call alignx(16,Ginv(1,1)) + + do i=1,dimen/3 + dtmp(i)=0.0d0 + do j=1,dimen/3 + dtmp(i)=dtmp(i)+Ginv(i,j)*ztmp(j) + enddo + enddo + do i=1,dimen/3 + ind=(i-1)*3+k+1 + d_a_tmp(ind)=dtmp(i) + enddo + enddo + return + end subroutine ginv_mult_test +#endif +!----------------------------------------------------------------------------- + subroutine fricmat_mult(z,d_a_tmp) + + use geometry_data, only: nres + use control_data + use MPI_data +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer :: IERROR,ierr +#endif +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.SETUP' +! include 'COMMON.TIME1' +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif + real(kind=8),dimension(dimen3) :: z,z1,d_a_tmp + real(kind=8),dimension(6*nres) :: temp !(maxres6) maxres6=6*maxres + real(kind=8) :: time00,time01 + integer :: i,j,k,ind,nres2 + nres2=2*nres +!el if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) + +#ifdef MPI + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then +! The matching BROADCAST for fg processors is called in ERGASTULUM + time00=MPI_Wtime() + call MPI_Bcast(9,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 +! print *,"Processor",myrank," BROADCAST iorder in FRICMAT_MULT" + endif +! call MPI_Barrier(FG_COMM,IERROR) + time00=MPI_Wtime() + call MPI_Scatterv(z,ng_counts(0),ng_start(0),& + MPI_DOUBLE_PRECISION,& + z1,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +! write (2,*) "My chunk of z" +! do i=1,3*my_ng_count +! write (2,*) i,z(i) +! enddo + time_scatter=time_scatter+MPI_Wtime()-time00 +#ifdef TIMING + time_scatter_fmatmult=time_scatter_fmatmult+MPI_Wtime()-time00 +#endif + time01=MPI_Wtime() + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + temp(ind)=0.0d0 + do j=1,my_ng_count + temp(ind)=temp(ind)-fricmat(j,i)*z1((j-1)*3+k+1) + enddo + enddo + enddo + time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 +! write (2,*) "Before REDUCE" +! write (2,*) "d_a_tmp before reduce" +! do i=1,dimen3 +! write (2,*) i,temp(i) +! enddo +! call flush(2) + time00=MPI_Wtime() + call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION,& + MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +! write (2,*) "After REDUCE" +! call flush(2) + else +#endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + d_a_tmp(ind)=0.0d0 + do j=1,dimen + d_a_tmp(ind)=d_a_tmp(ind) & + -fricmat(j,i)*z((j-1)*3+k+1) + enddo + enddo + enddo +#ifdef TIMING + time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 +#endif +#ifdef MPI + endif +#endif +! write (iout,*) "Vector d_a" +! do i=1,dimen3 +! write (2,*) i,d_a_tmp(i) +! enddo + return + end subroutine fricmat_mult +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module REMD diff --git a/source/unres/REMD.f90 b/source/unres/REMD.f90 deleted file mode 100644 index edbcc8e..0000000 --- a/source/unres/REMD.f90 +++ /dev/null @@ -1,772 +0,0 @@ - module REMD -!----------------------------------------------------------------------------- - use io_units - use MD_data - use REMD_data - use muca_md - - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! lagrangian_lesyng.F -!----------------------------------------------------------------------------- - subroutine lagrangian -!------------------------------------------------------------------------- -! This subroutine contains the total lagrangain from which the accelerations -! are obtained. For numerical gradient checking, the derivetive of the -! lagrangian in the velocities and coordinates are calculated seperately -!------------------------------------------------------------------------- -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use comm_cipiszcze - use energy_data - use geometry_data, only: nres - use control_data !el, only: mucadyn,lmuca -#ifdef MPI - include 'mpif.h' - real(kind=8) :: time00 -#endif -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -! include 'COMMON.MUCA' -! include 'COMMON.TIME1' - - integer :: i,j,ind,itime - real(kind=8) :: zapas(6*nres) !,muca_factor !maxres6=6*maxres - logical :: lprn = .false. -!el common /cipiszcze/ itime - itime = itt_comm - -#ifdef TIMING - time00=MPI_Wtime() -#endif - do j=1,3 - zapas(j)=-gcart(j,0) - enddo - ind=3 - if (lprn) then - write (iout,*) "Potential forces backbone" - endif - do i=nnt,nct-1 - if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') & - i,(-gcart(j,i),j=1,3) - do j=1,3 - ind=ind+1 - zapas(ind)=-gcart(j,i) - enddo - enddo - if (lprn) write (iout,*) "Potential forces sidechain" - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') & - i,(-gcart(j,i),j=1,3) - do j=1,3 - ind=ind+1 - zapas(ind)=-gxcart(j,i) - enddo - endif - enddo - - call ginv_mult(zapas,d_a_work) - - do j=1,3 - d_a(j,0)=d_a_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_a(j,i)=d_a_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - d_a(j,i+nres)=d_a_work(ind) - enddo - endif - enddo - - if(lmuca) then - imtime=imtime+1 - if(mucadyn.gt.0) call muca_update(potE) - factor=muca_factor(potE)*t_bath*Rb - -!d print *,'lmuca ',factor,potE - do j=1,3 - d_a(j,0)=d_a(j,0)*factor - enddo - do i=nnt,nct-1 - do j=1,3 - d_a(j,i)=d_a(j,i)*factor - enddo - enddo - do i=nnt,nct - do j=1,3 - d_a(j,i+nres)=d_a(j,i+nres)*factor - enddo - enddo - - endif - - if (lprn) then - write(iout,*) 'acceleration 3D' - write (iout,'(i3,3f10.5,3x,3f10.5)') 0,(d_a(j,0),j=1,3) - do i=nnt,nct-1 - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3) - enddo - do i=nnt,nct - write (iout,'(i3,3f10.5,3x,3f10.5)') & - i+nres,(d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef TIMING - time_lagrangian=time_lagrangian+MPI_Wtime()-time00 -#endif - return - end subroutine lagrangian -!----------------------------------------------------------------------------- - subroutine setup_MD_matrices - - use geometry_data, only: nres,nside - use control_data - use MPI_data - use energy_data - use geometry, only:int_bounds - use md_calc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer :: ierror - real(kind=8) :: time00 -#endif -! include 'COMMON.SETUP' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' - logical :: lprn = .false. - logical :: osob - real(kind=8) :: dtdi - real(kind=8),dimension(2*nres) :: massvec,sqreig !(maxres2) maxres2=2*maxres -!el real(kind=8),dimension(:),allocatable :: Ghalf -!el real(kind=8),dimension(2*nres*(2*nres+1)/2) :: Ghalf !(mmaxres2) (mmaxres2=(maxres2*(maxres2+1)/2)) -!el real(kind=8),dimension(2*nres,2*nres) :: Gcopy !(maxres2,maxres2) -!el real(kind=8),dimension(:,:),allocatable :: Gcopy - real(kind=8),dimension(8*6*nres) :: work !(8*maxres6) - integer,dimension(6*nres) :: iwork !(maxres6) maxres6=6*maxres -!el common /przechowalnia/ Gcopy,Ghalf - real(kind=8) :: coeff - integer :: i,j,ind,ind1,k,ii,jj,m,m1,ii1,iti,nres2,ierr - nres2=2*nres - - if(.not.allocated(Gcopy)) allocate(Gcopy(nres2,nres2)) !(maxres2,maxres2) - if(.not.allocated(Ghalf)) allocate(Ghalf(nres2*(nres2+1)/2)) !mmaxres2=(maxres2*(maxres+1)/2) -! -! Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the -! inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv) -! -! Determine the number of degrees of freedom (dimen) and the number of -! sites (dimen1) - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() - call MPI_Bcast(5,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER,& - ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1,& - MPI_INTEGER,FG_COMM,IERROR) - write (iout,*) 'Processor:',fg_rank,' CG group',kolor,& - ' absolute rank',myrank,' igmult_start',igmult_start,& - ' igmult_end',igmult_end,' count',my_ng_count - write (iout,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) - write (iout,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - call flush(iout) - else -#endif - igmult_start=1 - igmult_end=dimen - my_ng_count=dimen -#ifdef MPI - endif -#endif -! write (iout,*) "dimen",dimen," dimen1",dimen1," dimen3",dimen3 -! Zeroing out A and fricmat - do i=1,dimen - do j=1,dimen - A(i,j)=0.0D0 - enddo - enddo -! Diagonal elements of the dC part of A and the respective friction coefficients - ind=1 - ind1=0 - do i=nnt,nct-1 - ind=ind+1 - ind1=ind1+1 - coeff=0.25d0*IP - massvec(ind1)=mp - Gmat(ind,ind)=coeff - A(ind1,ind)=0.5d0 - enddo - -! Off-diagonal elements of the dC part of A - k=3 - do i=1,nct-nnt - do j=1,i - A(i,j)=1.0d0 - enddo - enddo -! Diagonal elements of the dX part of A and the respective friction coefficients - m=nct-nnt - m1=nct-nnt+1 - ind=0 - ind1=0 - msc(ntyp1)=1.0d0 - do i=nnt,nct - ind=ind+1 - ii = ind+m - iti=itype(i) - massvec(ii)=msc(iabs(iti)) - if (iti.ne.10 .and. iti.ne.ntyp1) then - ind1=ind1+1 - ii1= ind1+m1 - A(ii,ii1)=1.0d0 - Gmat(ii1,ii1)=ISC(iabs(iti)) - endif - enddo -! Off-diagonal elements of the dX part of A - ind=0 - k=nct-nnt - do i=nnt,nct - iti=itype(i) - ind=ind+1 - do j=nnt,i - ii = ind - jj = j-nnt+1 - A(k+ii,jj)=1.0d0 - enddo - enddo - if (lprn) then - write (iout,*) - write (iout,*) "Vector massvec" - do i=1,dimen1 - write (iout,*) i,massvec(i) - enddo - write (iout,'(//a)') "A" - call matout(dimen,dimen1,nres2,nres2,A) - endif - -! Calculate the G matrix (store in Gmat) - do k=1,dimen - do i=1,dimen - dtdi=0.0d0 - do j=1,dimen1 - dtdi=dtdi+A(j,k)*A(j,i)*massvec(j) - enddo - Gmat(k,i)=Gmat(k,i)+dtdi - enddo - enddo - - if (lprn) then - write (iout,'(//a)') "Gmat" - call matout(dimen,dimen,nres2,nres2,Gmat) - endif - do i=1,dimen - do j=1,dimen - Ginv(i,j)=0.0d0 - Gcopy(i,j)=Gmat(i,j) - enddo - Ginv(i,i)=1.0d0 - enddo -! Invert the G matrix - call MATINVERT(dimen,nres2,Gcopy,Ginv,osob) - if (lprn) then - write (iout,'(//a)') "Ginv" - call matout(dimen,dimen,nres2,nres2,Ginv) - endif -#ifdef MPI - if (nfgtasks.gt.1) then - myginv_ng_count=nres2*my_ng_count - call MPI_Allgather(nres2*igmult_start,1,MPI_INTEGER,& - nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER,& - nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) - write (iout,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) - write (iout,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) - call flush(iout) -! call MPI_Scatterv(ginv(1,1),nginv_counts(0), -! & nginv_start(0),MPI_DOUBLE_PRECISION,ginv, -! & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -! call MPI_Barrier(FG_COMM,IERR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0),& - nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1),& - myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -! write (iout,*) "Master's chunk of ginv" -! call MATOUT2(my_ng_count,dimen,maxres2,maxres2,ginv) - endif -#endif - if (osob) then - write (iout,*) "The G matrix is singular." - stop - endif -! Compute G**(-1/2) and G**(1/2) - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=Gmat(i,j) - enddo - enddo - call gldiag(nres2,dimen,dimen,Ghalf,work,Geigen,Gvec,& - ierr,iwork) - if (lprn) then - write (iout,'(//a)') & - "Eigenvectors and eigenvalues of the G matrix" - call eigout(dimen,dimen,nres2,nres2,Gvec,Geigen) - endif - do i=1,dimen - sqreig(i)=dsqrt(Geigen(i)) - enddo - do i=1,dimen - do j=1,dimen - Gsqrp(i,j)=0.0d0 - Gsqrm(i,j)=0.0d0 - Gcopy(i,j)=0.0d0 - do k=1,dimen - Gsqrp(i,j)=Gsqrp(i,j)+Gvec(i,k)*Gvec(j,k)*sqreig(k) - Gsqrm(i,j)=Gsqrm(i,j)+Gvec(i,k)*Gvec(j,k)/sqreig(k) - Gcopy(i,j)=Gcopy(i,j)+Gvec(i,k)*Gvec(j,k)*Geigen(k) - enddo - enddo - enddo - if (lprn) then - write (iout,*) "Comparison of original and restored G" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,5f10.5)') i,j,Gmat(i,j),Gcopy(i,j),& - Gmat(i,j)-Gcopy(i,j),Gsqrp(i,j),Gsqrm(i,j) - enddo - enddo - endif -! deallocate(Gcopy) - return - end subroutine setup_MD_matrices -!----------------------------------------------------------------------------- - subroutine EIGOUT(NC,NR,LM2,LM3,A,B) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer :: LM2,LM3,NC,NR,KA,KC,KB,I,J,N - real(kind=8) :: A(LM2,LM3),B(LM2) - KA=1 - KC=6 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,601) (B(I),I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.10) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+6 - GO TO 1 - 600 FORMAT (// 9H ROOT NO.,I4,9I11) - 601 FORMAT (/5X,10(1PE11.4)) - 602 FORMAT (2H ) - 603 FORMAT (I5,10F11.5) - 604 FORMAT (1H1) - end subroutine EIGOUT -!----------------------------------------------------------------------------- - subroutine MATOUT(NC,NR,LM2,LM3,A) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer :: LM2,LM3,NC,NR,KA,KC,KB,I,J,N - real(kind=8) :: A(LM2,LM3) - KA=1 - KC=6 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.10) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+6 - GO TO 1 - 600 FORMAT (//5x,9I11) - 602 FORMAT (2H ) - 603 FORMAT (I5,10F11.3) - 604 FORMAT (1H1) - end subroutine MATOUT -!----------------------------------------------------------------------------- - subroutine MATOUT1(NC,NR,LM2,LM3,A) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer :: LM2,LM3,NC,NR,KA,KC,KB,I,J,N - real(kind=8) :: A(LM2,LM3) - KA=1 - KC=21 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.3) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+21 - GO TO 1 - 600 FORMAT (//5x,7(3I5,2x)) - 602 FORMAT (2H ) - 603 FORMAT (I5,7(3F5.1,2x)) - 604 FORMAT (1H1) - end subroutine MATOUT1 -!----------------------------------------------------------------------------- - subroutine MATOUT2(NC,NR,LM2,LM3,A) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer :: I,J,KA,KC,KB,N - integer :: LM2,LM3,NC,NR - real(kind=8) :: A(LM2,LM3) - KA=1 - KC=12 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.3) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+12 - GO TO 1 - 600 FORMAT (//5x,4(3I9,2x)) - 602 FORMAT (2H ) - 603 FORMAT (I5,4(3F9.3,2x)) - 604 FORMAT (1H1) - end subroutine MATOUT2 -!----------------------------------------------------------------------------- - subroutine ginv_mult(z,d_a_tmp) - - use geometry_data, only: nres - use control_data - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer :: ierr,ierror -#endif -! include 'COMMON.SETUP' -! include 'COMMON.TIME1' -! include 'COMMON.MD' - real(kind=8),dimension(dimen3) :: z,z1,d_a_tmp - real(kind=8),dimension(6*nres) :: temp !(maxres6) maxres6=6*maxres - real(kind=8) :: time00,time01 - integer :: i,j,k,ind -#ifdef MPI - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -! The matching BROADCAST for fg processors is called in ERGASTULUM - time00=MPI_Wtime() - call MPI_Bcast(4,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -! print *,"Processor",myrank," BROADCAST iorder in GINV_MULT" - endif -! write (2,*) "time00",time00 -! write (2,*) "Before Scatterv" -! call flush(2) -! write (2,*) "Whole z (for FG master)" -! do i=1,dimen -! write (2,*) i,z(i) -! enddo -! call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() -!elwrite(iout,*) "do tej pory jest OK, MPI_Scatterv w ginv_mult" - call MPI_Scatterv(z,ng_counts(0),ng_start(0),& - MPI_DOUBLE_PRECISION,& - z1,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -! write (2,*) "My chunk of z" -! do i=1,3*my_ng_count -! write (2,*) i,z(i) -! enddo -! write (2,*) "After SCATTERV" -! call flush(2) -! write (2,*) "MPI_Wtime",MPI_Wtime() - time_scatter=time_scatter+MPI_Wtime()-time00 -#ifdef TIMING - time_scatter_ginvmult=time_scatter_ginvmult+MPI_Wtime()-time00 -#endif -! write (2,*) "time_scatter",time_scatter -! write (2,*) "dimen",dimen," dimen3",dimen3," my_ng_count", -! & my_ng_count -! call flush(2) - time01=MPI_Wtime() - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - temp(ind)=0.0d0 - do j=1,my_ng_count -! write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1, -! & Ginv(i,j),z((j-1)*3+k+1), -! & Ginv(i,j)*z((j-1)*3+k+1) -! temp(ind)=temp(ind)+Ginv(i,j)*z((j-1)*3+k+1) - temp(ind)=temp(ind)+Ginv(j,i)*z1((j-1)*3+k+1) - enddo - enddo - enddo - time_ginvmult=time_ginvmult+MPI_Wtime()-time01 -! write (2,*) "Before REDUCE" -! call flush(2) -! write (2,*) "z before reduce" -! do i=1,dimen -! write (2,*) i,temp(i) -! enddo - time00=MPI_Wtime() - call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION,& - MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -! write (2,*) "After REDUCE" -! call flush(2) - else -#endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_a_tmp(ind)=0.0d0 - do j=1,dimen -! write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1 -! call flush(2) -! & Ginv(i,j),z((j-1)*3+k+1), -! & Ginv(i,j)*z((j-1)*3+k+1) - d_a_tmp(ind)=d_a_tmp(ind) & - +Ginv(j,i)*z((j-1)*3+k+1) -! d_a_tmp(ind)=d_a_tmp(ind) -! & +Ginv(i,j)*z((j-1)*3+k+1) - enddo - enddo - enddo -#ifdef TIMING - time_ginvmult=time_ginvmult+MPI_Wtime()-time01 -#endif -#ifdef MPI - endif -#endif - return - end subroutine ginv_mult -!----------------------------------------------------------------------------- -#ifdef GINV_MULT - subroutine ginv_mult_test(z,d_a_tmp) - -! include 'DIMENSIONS' -!el integer :: dimen -! include 'COMMON.MD' - real(kind=8),dimension(dimen) :: z,d_a_tmp - real(kind=8),dimension(dimen/3) :: ztmp,dtmp - integer :: i,j,k,ind -! do i=1,dimen -! d_a_tmp(i)=0.0d0 -! do j=1,dimen -! d_a_tmp(i)=d_a_tmp(i)+Ginv(i,j)*z(j) -! enddo -! enddo -! -! return - -!ibm* unroll(3) - do k=0,2 - do j=1,dimen/3 - ztmp(j)=z((j-1)*3+k+1) - enddo - - call alignx(16,ztmp(1)) - call alignx(16,dtmp(1)) - call alignx(16,Ginv(1,1)) - - do i=1,dimen/3 - dtmp(i)=0.0d0 - do j=1,dimen/3 - dtmp(i)=dtmp(i)+Ginv(i,j)*ztmp(j) - enddo - enddo - do i=1,dimen/3 - ind=(i-1)*3+k+1 - d_a_tmp(ind)=dtmp(i) - enddo - enddo - return - end subroutine ginv_mult_test -#endif -!----------------------------------------------------------------------------- - subroutine fricmat_mult(z,d_a_tmp) - - use geometry_data, only: nres - use control_data - use MPI_data -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer :: IERROR,ierr -#endif -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.SETUP' -! include 'COMMON.TIME1' -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif - real(kind=8),dimension(dimen3) :: z,z1,d_a_tmp - real(kind=8),dimension(6*nres) :: temp !(maxres6) maxres6=6*maxres - real(kind=8) :: time00,time01 - integer :: i,j,k,ind,nres2 - nres2=2*nres -!el if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) - -#ifdef MPI - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -! The matching BROADCAST for fg processors is called in ERGASTULUM - time00=MPI_Wtime() - call MPI_Bcast(9,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -! print *,"Processor",myrank," BROADCAST iorder in FRICMAT_MULT" - endif -! call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(z,ng_counts(0),ng_start(0),& - MPI_DOUBLE_PRECISION,& - z1,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -! write (2,*) "My chunk of z" -! do i=1,3*my_ng_count -! write (2,*) i,z(i) -! enddo - time_scatter=time_scatter+MPI_Wtime()-time00 -#ifdef TIMING - time_scatter_fmatmult=time_scatter_fmatmult+MPI_Wtime()-time00 -#endif - time01=MPI_Wtime() - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - temp(ind)=0.0d0 - do j=1,my_ng_count - temp(ind)=temp(ind)-fricmat(j,i)*z1((j-1)*3+k+1) - enddo - enddo - enddo - time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 -! write (2,*) "Before REDUCE" -! write (2,*) "d_a_tmp before reduce" -! do i=1,dimen3 -! write (2,*) i,temp(i) -! enddo -! call flush(2) - time00=MPI_Wtime() - call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION,& - MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -! write (2,*) "After REDUCE" -! call flush(2) - else -#endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_a_tmp(ind)=0.0d0 - do j=1,dimen - d_a_tmp(ind)=d_a_tmp(ind) & - -fricmat(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo -#ifdef TIMING - time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 -#endif -#ifdef MPI - endif -#endif -! write (iout,*) "Vector d_a" -! do i=1,dimen3 -! write (2,*) i,d_a_tmp(i) -! enddo - return - end subroutine fricmat_mult -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module REMD diff --git a/source/unres/check_bond.F90 b/source/unres/check_bond.F90 new file mode 100644 index 0000000..dbb1d6c --- /dev/null +++ b/source/unres/check_bond.F90 @@ -0,0 +1,38 @@ + module check_bond_ + + use names + use geometry_data + use energy_data + use geometry, only: chainbuild + use energy, only: etotal + implicit none +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! check_bond.f +!----------------------------------------------------------------------------- + subroutine check_bond +! Subroutine is checking if the fitted function which describs sc_rot_pot +! is correct, printing, alpha,beta, energy, data - for some known theta. +! theta angle is read from the input file. Sc_rot_pot are printed +! for the second residue in sequance. +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.CHAIN' + real(kind=8),dimension(0:n_ene) :: energia +!el local variables + integer :: it,i + + it=itype(2) + do i=1,101 + vbld(nres+2)=0.5d0+0.05d0*(i-1) + call chainbuild + call etotal(energia) + write (2,*) vbld(nres+2),energia(17) + enddo + return + end subroutine check_bond + + end module check_bond_ diff --git a/source/unres/check_bond.f90 b/source/unres/check_bond.f90 deleted file mode 100644 index dbb1d6c..0000000 --- a/source/unres/check_bond.f90 +++ /dev/null @@ -1,38 +0,0 @@ - module check_bond_ - - use names - use geometry_data - use energy_data - use geometry, only: chainbuild - use energy, only: etotal - implicit none -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! check_bond.f -!----------------------------------------------------------------------------- - subroutine check_bond -! Subroutine is checking if the fitted function which describs sc_rot_pot -! is correct, printing, alpha,beta, energy, data - for some known theta. -! theta angle is read from the input file. Sc_rot_pot are printed -! for the second residue in sequance. -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.CHAIN' - real(kind=8),dimension(0:n_ene) :: energia -!el local variables - integer :: it,i - - it=itype(2) - do i=1,101 - vbld(nres+2)=0.5d0+0.05d0*(i-1) - call chainbuild - call etotal(energia) - write (2,*) vbld(nres+2),energia(17) - enddo - return - end subroutine check_bond - - end module check_bond_ diff --git a/source/unres/cinfo.F90 b/source/unres/cinfo.F90 new file mode 100644 index 0000000..d38c220 --- /dev/null +++ b/source/unres/cinfo.F90 @@ -0,0 +1,39 @@ +! DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C +! 0 40376 67 + subroutine cinfo +! include 'COMMON.IOUNITS' + use io_units + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version 0.40376 build 67' + write(iout,*)'compiled Fri Mar 10 14:56:02 2017' + write(iout,*)'compiled by emilial@piasek4' + write(iout,*)'OS name: Linux ' + write(iout,*)'OS release: 3.2.0-111-generic ' + write(iout,*)'OS version:',& + ' #153-Ubuntu SMP Wed Sep 21 21:23:31 UTC 2016 ' + write(iout,*)'flags:' + write(iout,*)'INSTALL_DIR = /users/software/mpich2-1.4.1p1_in...' + write(iout,*)'FC= ${INSTALL_DIR}/bin/mpif90' + write(iout,*)'OPT = -O3 -ip ' + write(iout,*)'FFLAGS = -fpp -c ${OPT} #-auto' + write(iout,*)'FFLAGSm = -fpp -c -O #-g -CA -CB -auto -zero -t...' + write(iout,*)'FFLAGS1 = -fpp -c -g -CA -CB #-auto #-zero -tra...' + write(iout,*)'FFLAGS2 = -fpp -c -g -O0 #-I$(INSTALL_DIR)/inc...' + write(iout,*)'FFLAGSE = -fpp -c ${OPT} #-g -CA -CB -auto -zer...' + write(iout,*)'ARCH = LINUX' + write(iout,*)'PP = /lib/cpp -P' + write(iout,*)'DATA_FILE= ./data' + write(iout,*)'data = names.o io_units.o calc_data.o compare_d...' + write(iout,*)'objects = xdrf/*.o \\' + write(iout,*)' prng_32.o math.o random.o geometry.o md_calc.o...' + write(iout,*)'NOMPI: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD6...' + write(iout,*)'NOMPI: EXE_FILE = ../../bin/unres_NO_MPI_F90_EL...' + write(iout,*)'GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 ...' + write(iout,*)'GAB: EXE_FILE = ../../bin/unres_GAB_F90_EL.exe' + write(iout,*)'4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -D...' + write(iout,*)'4P: EXE_FILE = ../../bin/unres_4P_F90_EL.exe' + write(iout,*)'E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD...' + write(iout,*)'E0LL2Y: EXE_FILE = ../../bin/unres_E0LL2Y_F90_E...' + write(iout,*)'++++ End of compile info ++++' + return + end subroutine cinfo diff --git a/source/unres/cinfo.f90 b/source/unres/cinfo.f90 deleted file mode 100644 index d38c220..0000000 --- a/source/unres/cinfo.f90 +++ /dev/null @@ -1,39 +0,0 @@ -! DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C -! 0 40376 67 - subroutine cinfo -! include 'COMMON.IOUNITS' - use io_units - write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version 0.40376 build 67' - write(iout,*)'compiled Fri Mar 10 14:56:02 2017' - write(iout,*)'compiled by emilial@piasek4' - write(iout,*)'OS name: Linux ' - write(iout,*)'OS release: 3.2.0-111-generic ' - write(iout,*)'OS version:',& - ' #153-Ubuntu SMP Wed Sep 21 21:23:31 UTC 2016 ' - write(iout,*)'flags:' - write(iout,*)'INSTALL_DIR = /users/software/mpich2-1.4.1p1_in...' - write(iout,*)'FC= ${INSTALL_DIR}/bin/mpif90' - write(iout,*)'OPT = -O3 -ip ' - write(iout,*)'FFLAGS = -fpp -c ${OPT} #-auto' - write(iout,*)'FFLAGSm = -fpp -c -O #-g -CA -CB -auto -zero -t...' - write(iout,*)'FFLAGS1 = -fpp -c -g -CA -CB #-auto #-zero -tra...' - write(iout,*)'FFLAGS2 = -fpp -c -g -O0 #-I$(INSTALL_DIR)/inc...' - write(iout,*)'FFLAGSE = -fpp -c ${OPT} #-g -CA -CB -auto -zer...' - write(iout,*)'ARCH = LINUX' - write(iout,*)'PP = /lib/cpp -P' - write(iout,*)'DATA_FILE= ./data' - write(iout,*)'data = names.o io_units.o calc_data.o compare_d...' - write(iout,*)'objects = xdrf/*.o \\' - write(iout,*)' prng_32.o math.o random.o geometry.o md_calc.o...' - write(iout,*)'NOMPI: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD6...' - write(iout,*)'NOMPI: EXE_FILE = ../../bin/unres_NO_MPI_F90_EL...' - write(iout,*)'GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 ...' - write(iout,*)'GAB: EXE_FILE = ../../bin/unres_GAB_F90_EL.exe' - write(iout,*)'4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -D...' - write(iout,*)'4P: EXE_FILE = ../../bin/unres_4P_F90_EL.exe' - write(iout,*)'E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD...' - write(iout,*)'E0LL2Y: EXE_FILE = ../../bin/unres_E0LL2Y_F90_E...' - write(iout,*)'++++ End of compile info ++++' - return - end subroutine cinfo diff --git a/source/unres/compare.F90 b/source/unres/compare.F90 index b65e57c..37d1690 100644 --- a/source/unres/compare.F90 +++ b/source/unres/compare.F90 @@ -5,7 +5,7 @@ use geometry_data use energy_data use control_data -#if .not. defined WHAM_RUN && .not. defined CLUSTER +#if !defined(WHAM_RUN) && !defined(CLUSTER) use compare_data use io_base use io_config @@ -21,7 +21,7 @@ ! !----------------------------------------------------------------------------- contains -#if .not. defined WHAM_RUN && .not. defined CLUSTER +#if !defined(WHAM_RUN) && !defined(CLUSTER) !----------------------------------------------------------------------------- ! contact.f !----------------------------------------------------------------------------- diff --git a/source/unres/control.F90 b/source/unres/control.F90 index 8d22bf0..ba3ddd3 100644 --- a/source/unres/control.F90 +++ b/source/unres/control.F90 @@ -123,7 +123,7 @@ !local variables el integer :: i,j,k,l,ichir1,ichir2,iblock,m,maxit -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) +!#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) mask_r=.false. #ifndef ISNAN ! NaNQ initialization @@ -136,6 +136,7 @@ #endif #endif +#if !defined(WHAM_RUN) && !defined(CLUSTER) kdiag=0 icorfl=0 iw=2 @@ -1732,7 +1733,7 @@ ! 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) +#if !defined(WHAM_RUN) && !defined(CLUSTER) #ifdef MPI walltime=MPI_WTIME() time_reduce=0.0d0 diff --git a/source/unres/data/CSA_data.F90 b/source/unres/data/CSA_data.F90 new file mode 100644 index 0000000..cd5835d --- /dev/null +++ b/source/unres/data/CSA_data.F90 @@ -0,0 +1,77 @@ + module csa_data +!----------------------------------------------------------------------------- +! Maximum number of generated conformations + integer,parameter :: mxio=1000 +! Maximum number of n7 generated conformations + integer,parameter :: mxio2=100 +! Maxmimum number of angles per residue + integer,parameter :: mxang=4 +! Maximum number of chains + integer,parameter :: mxch=1 +!----------------------------------------------------------------------------- +! commom.bank +! common/varin/ + real(kind=8),dimension(:,:,:,:),allocatable :: dihang_in !(mxang,maxres,mxch,mxio) +! common/minvar/ +! real(kind=8),dimension(:,:,:,:),allocatable :: dihang !(mxang,maxres,mxch,mxio) + real(kind=8),dimension(:),allocatable :: rmsn,pncn !(mxio) +! integer,dimension(:),allocatable :: nss_out !(mxio) +! integer,dimension(:,:),allocatable ::iss_out,jss_out !(maxss,mxio) +! common/bank/ + real(kind=8),dimension(:,:,:,:),allocatable :: rvar,bvar!(mxang,maxres,mxch,mxio) + real(kind=8),dimension(:),allocatable :: bene,rene,& + brmsn,rrmsn,bpncn,rpncn !(mxio) + integer,dimension(:),allocatable :: ibank!,is,jbank !(mxio) + real(kind=8) :: cutdif,&!,avedif,difmin,ebmin,ebmax,ebmaxt,& + dele,difcut,rmscut,pnccut +! real(kind=8),dimension(:,:),allocatable :: dij !(mxio,mxio) + integer :: ibmin,ibmax,nbank,ntbank,ntbankm,nconf,iuse,& + nstep,icycle,iseed,iref,nconf_in,ilastnstep,nadd +! common/bank_disulfid/ + integer,dimension(:),allocatable :: bvar_nss,bvar_ns !(mxio) + integer,dimension(:,:),allocatable :: bvar_s !(maxss,mxio) + integer,dimension(:,:,:),allocatable :: bvar_ss !(2,maxss,mxio) +!----------------------------------------------------------------------- +! common.iounits +! I/O units used by the program +!----------------------------------------------------------------------- +! 9/18/99 - unit ifourier and filename fouriername included to identify +! the file from which the coefficients of second-order Fourier expansion +! of the local-interaction energy are read. +! 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) +! included. +!----------------------------------------------------------------------- +! CSA I/O units & files +! common /csafiles/ + character(len=256) :: csa_rbank,csa_seed,csa_history,csa_bank,& + csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int,& + csa_bank_reminimized,csa_native_int,csa_in +! common /csaunits/ + integer :: icsa_rbank,icsa_seed,icsa_history,icsa_bank,& + icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int,& + icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb +!----------------------------------------------------------------------------- +! common.csa + integer :: irestart,ndiff +! common/alphaa/ +! integer,dimension(:),allocatable :: ngroup !(mxgr) +! integer,dimension(:,:,:),allocatable :: igroup !(3,mxang,mxgr) + integer :: numch +! common/csa_input/ + real(kind=8) :: cut1,cut2,estop + real(kind=8) :: eglob_csa + integer :: jstart,jend,& + n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0,& + is1,is2,nseed,ntotal,icmax,nstmax,nran0,nran1,irr + integer :: nglob_csa,nmin_csa +! common/dih_control/ + real(kind=8) :: rdih_bias +! common/diffcuta/ + real(kind=8) :: diffcut +!----------------------------------------------------------------------------- +! Maximum number of groups of angles + integer :: mxgr +!----------------------------------------------------------------------------- + real(kind=8) :: rmsdbc1 +!----------------------------------------------------------------------------- + end module csa_data diff --git a/source/unres/data/CSA_data.f90 b/source/unres/data/CSA_data.f90 deleted file mode 100644 index cd5835d..0000000 --- a/source/unres/data/CSA_data.f90 +++ /dev/null @@ -1,77 +0,0 @@ - module csa_data -!----------------------------------------------------------------------------- -! Maximum number of generated conformations - integer,parameter :: mxio=1000 -! Maximum number of n7 generated conformations - integer,parameter :: mxio2=100 -! Maxmimum number of angles per residue - integer,parameter :: mxang=4 -! Maximum number of chains - integer,parameter :: mxch=1 -!----------------------------------------------------------------------------- -! commom.bank -! common/varin/ - real(kind=8),dimension(:,:,:,:),allocatable :: dihang_in !(mxang,maxres,mxch,mxio) -! common/minvar/ -! real(kind=8),dimension(:,:,:,:),allocatable :: dihang !(mxang,maxres,mxch,mxio) - real(kind=8),dimension(:),allocatable :: rmsn,pncn !(mxio) -! integer,dimension(:),allocatable :: nss_out !(mxio) -! integer,dimension(:,:),allocatable ::iss_out,jss_out !(maxss,mxio) -! common/bank/ - real(kind=8),dimension(:,:,:,:),allocatable :: rvar,bvar!(mxang,maxres,mxch,mxio) - real(kind=8),dimension(:),allocatable :: bene,rene,& - brmsn,rrmsn,bpncn,rpncn !(mxio) - integer,dimension(:),allocatable :: ibank!,is,jbank !(mxio) - real(kind=8) :: cutdif,&!,avedif,difmin,ebmin,ebmax,ebmaxt,& - dele,difcut,rmscut,pnccut -! real(kind=8),dimension(:,:),allocatable :: dij !(mxio,mxio) - integer :: ibmin,ibmax,nbank,ntbank,ntbankm,nconf,iuse,& - nstep,icycle,iseed,iref,nconf_in,ilastnstep,nadd -! common/bank_disulfid/ - integer,dimension(:),allocatable :: bvar_nss,bvar_ns !(mxio) - integer,dimension(:,:),allocatable :: bvar_s !(maxss,mxio) - integer,dimension(:,:,:),allocatable :: bvar_ss !(2,maxss,mxio) -!----------------------------------------------------------------------- -! common.iounits -! I/O units used by the program -!----------------------------------------------------------------------- -! 9/18/99 - unit ifourier and filename fouriername included to identify -! the file from which the coefficients of second-order Fourier expansion -! of the local-interaction energy are read. -! 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) -! included. -!----------------------------------------------------------------------- -! CSA I/O units & files -! common /csafiles/ - character(len=256) :: csa_rbank,csa_seed,csa_history,csa_bank,& - csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int,& - csa_bank_reminimized,csa_native_int,csa_in -! common /csaunits/ - integer :: icsa_rbank,icsa_seed,icsa_history,icsa_bank,& - icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int,& - icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb -!----------------------------------------------------------------------------- -! common.csa - integer :: irestart,ndiff -! common/alphaa/ -! integer,dimension(:),allocatable :: ngroup !(mxgr) -! integer,dimension(:,:,:),allocatable :: igroup !(3,mxang,mxgr) - integer :: numch -! common/csa_input/ - real(kind=8) :: cut1,cut2,estop - real(kind=8) :: eglob_csa - integer :: jstart,jend,& - n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0,& - is1,is2,nseed,ntotal,icmax,nstmax,nran0,nran1,irr - integer :: nglob_csa,nmin_csa -! common/dih_control/ - real(kind=8) :: rdih_bias -! common/diffcuta/ - real(kind=8) :: diffcut -!----------------------------------------------------------------------------- -! Maximum number of groups of angles - integer :: mxgr -!----------------------------------------------------------------------------- - real(kind=8) :: rmsdbc1 -!----------------------------------------------------------------------------- - end module csa_data diff --git a/source/unres/data/MCM_data.F90 b/source/unres/data/MCM_data.F90 new file mode 100644 index 0000000..b698318 --- /dev/null +++ b/source/unres/data/MCM_data.F90 @@ -0,0 +1,73 @@ + module mcm_data +!----------------------------------------------------------------------------- +! Max. number of stored confs. in MC/MCM simulation + integer,parameter :: maxsave=20 +!----------------------------------------------------------------------------- +! common.mce +! common /mce/ + real(kind=8) :: emin,emax + logical :: ent_read +! common /pool/ + real(kind=8) :: pool_fraction +! common /mce_counters/ + integer :: save_frequency,message_frequency,pool_read_freq,& + pool_save_freq,print_freq +!----------------------------------------------------------------------------- +! commom.mcm +!... Following COMMON block contains general variables controlling the MC/MCM +!... procedure +!----------------------------------------------------------------------------- +! common /mcm/ + real(kind=8) :: Tcur,Tmin,Tmax,TstepH,TstepC,RanFract,& + overlap_cut,e_up,delte,Rbol,betbol + integer :: nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,& + maxrepm,maxoverlap,ntrial,max_mcm_it,ngen,ntherm,nrepm,neneval,& + nsave,nsweep,print_mc + integer,dimension(:),allocatable :: nsave_part !(max_cg_procs) + logical :: print_stat,print_int +!----------------------------------------------------------------------------- +!... The meaning of the above variables is as follows: +!... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; +!... NstepC,NStepH - Number of cooling and heating steps, respectively; +!... TstepH,TstepC - factors by which T is multiplied in order to be +!... increased or decreased. +!... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); +!... Rbol - the gas constant; +!... RanFract - the chance that a new conformation will be random-generated; +!... maxacc - maximum number of accepted conformations; +!... maxgen,ngen - Maximum and current number of generated conformations; +!... maxtrial,ntrial - maximum number of trials before temperature is increased +!... and current number of trials, respectively; +!... maxrepm,nrepm - maximum number of allowed minima repetition and current +!... number of minima repetitions, respectively; +!... maxoverlap - max. # of overlapping confs generated in a single iteration; +!... neneval - number of energy evaluations; +!... nsave - number of confs. in the backup array; +!... nsweep - the number of macroiterations in generating the distributions. +!------------------------------------------------------------------------------ +!... Following COMMON block contains variables controlling motion. +!------------------------------------------------------------------------------ +! common /move/ + real(kind=8),dimension(:),allocatable :: sumpro_type !(0:MaxMoveType) + integer :: nmove + integer,dimension(:),allocatable :: moves,moves_acc !(-1:MaxMoveType+1) +!... maxgen,ngen - Maximum and current number of generated conformations; +! common /accept_stats/ + integer :: nacc_tot +! common /windows/ + integer :: nwindow + integer,dimension(:),allocatable :: winstart,winend,winlen !(maxres) +! common /moveID/ + character(len=16),dimension(:),allocatable :: MovTypID !(-1:MaxMoveType+1) +!----------------------------------------------------------------------------- +! common.var +! Store the angles and variables corresponding to old conformations (for use +! in MCM). +! common /oldgeo/ + real(kind=8),dimension(:,:),allocatable :: varsave !(maxvar,maxsave)(maxvar=6*maxres) + real(kind=8),dimension(:),allocatable :: esave !(maxsave) + integer,dimension(:),allocatable :: Origin !(maxsave) + integer :: nstore +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module mcm_data diff --git a/source/unres/data/MCM_data.f90 b/source/unres/data/MCM_data.f90 deleted file mode 100644 index b698318..0000000 --- a/source/unres/data/MCM_data.f90 +++ /dev/null @@ -1,73 +0,0 @@ - module mcm_data -!----------------------------------------------------------------------------- -! Max. number of stored confs. in MC/MCM simulation - integer,parameter :: maxsave=20 -!----------------------------------------------------------------------------- -! common.mce -! common /mce/ - real(kind=8) :: emin,emax - logical :: ent_read -! common /pool/ - real(kind=8) :: pool_fraction -! common /mce_counters/ - integer :: save_frequency,message_frequency,pool_read_freq,& - pool_save_freq,print_freq -!----------------------------------------------------------------------------- -! commom.mcm -!... Following COMMON block contains general variables controlling the MC/MCM -!... procedure -!----------------------------------------------------------------------------- -! common /mcm/ - real(kind=8) :: Tcur,Tmin,Tmax,TstepH,TstepC,RanFract,& - overlap_cut,e_up,delte,Rbol,betbol - integer :: nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,& - maxrepm,maxoverlap,ntrial,max_mcm_it,ngen,ntherm,nrepm,neneval,& - nsave,nsweep,print_mc - integer,dimension(:),allocatable :: nsave_part !(max_cg_procs) - logical :: print_stat,print_int -!----------------------------------------------------------------------------- -!... The meaning of the above variables is as follows: -!... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; -!... NstepC,NStepH - Number of cooling and heating steps, respectively; -!... TstepH,TstepC - factors by which T is multiplied in order to be -!... increased or decreased. -!... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); -!... Rbol - the gas constant; -!... RanFract - the chance that a new conformation will be random-generated; -!... maxacc - maximum number of accepted conformations; -!... maxgen,ngen - Maximum and current number of generated conformations; -!... maxtrial,ntrial - maximum number of trials before temperature is increased -!... and current number of trials, respectively; -!... maxrepm,nrepm - maximum number of allowed minima repetition and current -!... number of minima repetitions, respectively; -!... maxoverlap - max. # of overlapping confs generated in a single iteration; -!... neneval - number of energy evaluations; -!... nsave - number of confs. in the backup array; -!... nsweep - the number of macroiterations in generating the distributions. -!------------------------------------------------------------------------------ -!... Following COMMON block contains variables controlling motion. -!------------------------------------------------------------------------------ -! common /move/ - real(kind=8),dimension(:),allocatable :: sumpro_type !(0:MaxMoveType) - integer :: nmove - integer,dimension(:),allocatable :: moves,moves_acc !(-1:MaxMoveType+1) -!... maxgen,ngen - Maximum and current number of generated conformations; -! common /accept_stats/ - integer :: nacc_tot -! common /windows/ - integer :: nwindow - integer,dimension(:),allocatable :: winstart,winend,winlen !(maxres) -! common /moveID/ - character(len=16),dimension(:),allocatable :: MovTypID !(-1:MaxMoveType+1) -!----------------------------------------------------------------------------- -! common.var -! Store the angles and variables corresponding to old conformations (for use -! in MCM). -! common /oldgeo/ - real(kind=8),dimension(:,:),allocatable :: varsave !(maxvar,maxsave)(maxvar=6*maxres) - real(kind=8),dimension(:),allocatable :: esave !(maxsave) - integer,dimension(:),allocatable :: Origin !(maxsave) - integer :: nstore -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module mcm_data diff --git a/source/unres/data/MD_data.F90 b/source/unres/data/MD_data.F90 new file mode 100644 index 0000000..bee0a24 --- /dev/null +++ b/source/unres/data/MD_data.F90 @@ -0,0 +1,100 @@ + module MD_data +!----------------------------------------------------------------------------- +#ifndef LANG0 +! commom.langevin +! common /langforc/ + real(kind=8),dimension(:,:),allocatable :: friction,stochforc !(3,0:MAXRES2) + real(kind=8),dimension(:),allocatable :: fric_work,stoch_work,& + fricgam !(MAXRES6) + real(kind=8),dimension(:,:),allocatable :: fricmat,fricvec,& + pfric_mat,vfric_mat,afric_mat,prand_mat,vrand_mat1,& + vrand_mat2 !(MAXRES2,MAXRES2) + real(kind=8),dimension(:,:,:),allocatable :: pfric0_mat,& + afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1,vrand0_mat2 !(MAXRES2,MAXRES2,0:maxflag_stoch) + logical,dimension(:),allocatable :: flag_stoch !(0:maxflag_stoch) +! common /langmat/ + real(kind=8),dimension(:,:),allocatable :: mt1,mt2,mt3 !(maxres2,maxres2) +!----------------------------------------------------------------------------- +#else +! commom.langevin.lang0 +! common /langforc/ + real(kind=8),dimension(:,:),allocatable :: friction,stochforc !(3,0:MAXRES2) + real(kind=8),dimension(:,:),allocatable :: fricmat,fricvec !(MAXRES2,MAXRES2) + real(kind=8),dimension(:),allocatable :: fric_work,stoch_work,& + fricgam !(MAXRES6) + logical,dimension(:),allocatable :: flag_stoch !(0:maxflag_stoch) + real(kind=8) :: vrand_mat1,vrand_mat2,prand_mat,vfric_mat,& + afric_mat,pfric_mat,pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,& + vrand0_mat1,vrand0_mat2 +! common /langmat/ + integer :: mt1,mt2,mt3 +#endif +!----------------------------------------------------------------------------- +! commom.hairpin in CSA module +!----------------------------------------------------------------------------- +! common.mce in MCM_MD module +!----------------------------------------------------------------------------- +! common.MD +! common /mdgrad/ in module.energy +! common /back_constr/ in module.energy +! common /qmeas/ in module.energy +! common /mdpar/ + real(kind=8) :: v_ini,d_time,d_time0,scal_fric,& + t_bath,tau_bath,dvmax,damax + integer :: n_timestep,ntime_split,ntime_split0,maxtime_split,& + ntwx,ntwe + logical :: mdpdb,large,print_compon,tbf,rest +! common /MDcalc/ + real(kind=8) :: totT,totE,potE,EK,amax,edriftmax,kinetic_T + real(kind=8),dimension(:),allocatable :: potEcomp !(0:n_ene+4) +! common /lagrange/ + real(kind=8),dimension(:,:),allocatable :: d_t,d_a,d_t_old !(3,0:MAXRES2) + real(kind=8),dimension(:),allocatable :: d_a_work !(6*MAXRES) + real(kind=8),dimension(:,:),allocatable :: Gmat,Ginv,A,& + Gsqrp,Gsqrm,Gvec !(maxres2,maxres2) + real(kind=8),dimension(:),allocatable :: Geigen !(maxres2) + real(kind=8),dimension(:),allocatable ::vtot !(maxres2) + logical :: reset_moment,reset_vel,rattle,RESPA + integer :: dimen,dimen1,dimen3 + integer :: lang,count_reset_moment,count_reset_vel +! common /inertia/ + real(kind=8) :: IP,mp + real(kind=8),dimension(:),allocatable :: ISC,msc !(ntyp+1) +! common /langevin/ + real(kind=8) :: rwat,etawat,stdfp,pstok,gamp!,Rb + real(kind=8) :: cPoise=2.9361d0, Rb=0.001986d0 + real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1) + real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp) + + real(kind=8),dimension(:),allocatable :: restok !(ntyp+1) + logical :: surfarea + integer :: reset_fricmat +! common /mdpmpi/ + integer :: igmult_start,igmult_end,my_ng_count,myginv_ng_count + integer,dimension(:),allocatable :: ng_start,ng_counts,& + nginv_counts !(0:MaxProcs-1) + integer,dimension(:),allocatable :: nginv_start !(0:MaxProcs) +!----------------------------------------------------------------------------- +! common.muca +! common /double_muca/ + real(kind=8) :: elow,ehigh,factor,hbin,factor_min + real(kind=8),dimension(:),allocatable :: emuca,nemuca,& + nemuca2,hist !(4*maxres) +! common /integer_muca/ + integer :: nmuca,imtime,muca_smooth +! common /mucarem/ + real(kind=8),dimension(:),allocatable :: elowi,ehighi !(maxprocs) +!----------------------------------------------------------------------------- +! Maximum number of timesteps for which stochastic MD matrices can be stored + integer,parameter :: maxflag_stoch=0 +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: setup_MD_matrices + real(kind=8),dimension(:,:),allocatable :: Gcopy !(maxres2,maxres2), maxres2=2*maxres +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: setup_fricmat,setup_MD_matrices + real(kind=8),dimension(:),allocatable :: Ghalf +!----------------------------------------------------------------------------- +! COMMON /BANII/ D + real(kind=8),DIMENSION(:),allocatable :: D_ban !(MAXRES6) maxres6=6*maxres +!----------------------------------------------------------------------------- + end module MD_data diff --git a/source/unres/data/MD_data.f90 b/source/unres/data/MD_data.f90 deleted file mode 100644 index bee0a24..0000000 --- a/source/unres/data/MD_data.f90 +++ /dev/null @@ -1,100 +0,0 @@ - module MD_data -!----------------------------------------------------------------------------- -#ifndef LANG0 -! commom.langevin -! common /langforc/ - real(kind=8),dimension(:,:),allocatable :: friction,stochforc !(3,0:MAXRES2) - real(kind=8),dimension(:),allocatable :: fric_work,stoch_work,& - fricgam !(MAXRES6) - real(kind=8),dimension(:,:),allocatable :: fricmat,fricvec,& - pfric_mat,vfric_mat,afric_mat,prand_mat,vrand_mat1,& - vrand_mat2 !(MAXRES2,MAXRES2) - real(kind=8),dimension(:,:,:),allocatable :: pfric0_mat,& - afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1,vrand0_mat2 !(MAXRES2,MAXRES2,0:maxflag_stoch) - logical,dimension(:),allocatable :: flag_stoch !(0:maxflag_stoch) -! common /langmat/ - real(kind=8),dimension(:,:),allocatable :: mt1,mt2,mt3 !(maxres2,maxres2) -!----------------------------------------------------------------------------- -#else -! commom.langevin.lang0 -! common /langforc/ - real(kind=8),dimension(:,:),allocatable :: friction,stochforc !(3,0:MAXRES2) - real(kind=8),dimension(:,:),allocatable :: fricmat,fricvec !(MAXRES2,MAXRES2) - real(kind=8),dimension(:),allocatable :: fric_work,stoch_work,& - fricgam !(MAXRES6) - logical,dimension(:),allocatable :: flag_stoch !(0:maxflag_stoch) - real(kind=8) :: vrand_mat1,vrand_mat2,prand_mat,vfric_mat,& - afric_mat,pfric_mat,pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,& - vrand0_mat1,vrand0_mat2 -! common /langmat/ - integer :: mt1,mt2,mt3 -#endif -!----------------------------------------------------------------------------- -! commom.hairpin in CSA module -!----------------------------------------------------------------------------- -! common.mce in MCM_MD module -!----------------------------------------------------------------------------- -! common.MD -! common /mdgrad/ in module.energy -! common /back_constr/ in module.energy -! common /qmeas/ in module.energy -! common /mdpar/ - real(kind=8) :: v_ini,d_time,d_time0,scal_fric,& - t_bath,tau_bath,dvmax,damax - integer :: n_timestep,ntime_split,ntime_split0,maxtime_split,& - ntwx,ntwe - logical :: mdpdb,large,print_compon,tbf,rest -! common /MDcalc/ - real(kind=8) :: totT,totE,potE,EK,amax,edriftmax,kinetic_T - real(kind=8),dimension(:),allocatable :: potEcomp !(0:n_ene+4) -! common /lagrange/ - real(kind=8),dimension(:,:),allocatable :: d_t,d_a,d_t_old !(3,0:MAXRES2) - real(kind=8),dimension(:),allocatable :: d_a_work !(6*MAXRES) - real(kind=8),dimension(:,:),allocatable :: Gmat,Ginv,A,& - Gsqrp,Gsqrm,Gvec !(maxres2,maxres2) - real(kind=8),dimension(:),allocatable :: Geigen !(maxres2) - real(kind=8),dimension(:),allocatable ::vtot !(maxres2) - logical :: reset_moment,reset_vel,rattle,RESPA - integer :: dimen,dimen1,dimen3 - integer :: lang,count_reset_moment,count_reset_vel -! common /inertia/ - real(kind=8) :: IP,mp - real(kind=8),dimension(:),allocatable :: ISC,msc !(ntyp+1) -! common /langevin/ - real(kind=8) :: rwat,etawat,stdfp,pstok,gamp!,Rb - real(kind=8) :: cPoise=2.9361d0, Rb=0.001986d0 - real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1) - real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp) - - real(kind=8),dimension(:),allocatable :: restok !(ntyp+1) - logical :: surfarea - integer :: reset_fricmat -! common /mdpmpi/ - integer :: igmult_start,igmult_end,my_ng_count,myginv_ng_count - integer,dimension(:),allocatable :: ng_start,ng_counts,& - nginv_counts !(0:MaxProcs-1) - integer,dimension(:),allocatable :: nginv_start !(0:MaxProcs) -!----------------------------------------------------------------------------- -! common.muca -! common /double_muca/ - real(kind=8) :: elow,ehigh,factor,hbin,factor_min - real(kind=8),dimension(:),allocatable :: emuca,nemuca,& - nemuca2,hist !(4*maxres) -! common /integer_muca/ - integer :: nmuca,imtime,muca_smooth -! common /mucarem/ - real(kind=8),dimension(:),allocatable :: elowi,ehighi !(maxprocs) -!----------------------------------------------------------------------------- -! Maximum number of timesteps for which stochastic MD matrices can be stored - integer,parameter :: maxflag_stoch=0 -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: setup_MD_matrices - real(kind=8),dimension(:,:),allocatable :: Gcopy !(maxres2,maxres2), maxres2=2*maxres -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: setup_fricmat,setup_MD_matrices - real(kind=8),dimension(:),allocatable :: Ghalf -!----------------------------------------------------------------------------- -! COMMON /BANII/ D - real(kind=8),DIMENSION(:),allocatable :: D_ban !(MAXRES6) maxres6=6*maxres -!----------------------------------------------------------------------------- - end module MD_data diff --git a/source/unres/data/MPI_data.F90 b/source/unres/data/MPI_data.F90 new file mode 100644 index 0000000..3ed522b --- /dev/null +++ b/source/unres/data/MPI_data.F90 @@ -0,0 +1,54 @@ + module MPI_data + +!----------------------------------------------------------------------------- + integer,parameter :: max_cg_procs=2048 +!----------------------------------------------------------------------------- +! commom.info +! NPROCS - total number of processors; +! MyID - processor's ID; +! MasterID - master processor's ID. + integer :: tag + integer,dimension(:),allocatable :: status !(MPI_STATUS_SIZE) +! common /info/ + integer :: myid,masterid,allgrp,dontcare,WhatsUp + logical,dimension(:),allocatable :: koniec !(0:maxprocs-1) +!el integer,dimension(:),allocatable :: ifinish !(maxprocs-1) +!... 5/12/96 - added variables for collective communication +! FGPROCS - Number of fine-grain processors per coarse-grain task; +! NCTASKS - Number of coarse-grain tasks; +! MYGROUP - label of the processor's FG group id; +! BOSSID - ID of group's master; +! FGLIST - list of group's FG processors. +! MSGLEN_VAR - length of the vector of variables passed to the fine-grain +! slave processors +! common /info1/ + integer :: fgprocs,nctasks,mygroup,bossid,cglabel,& + cgGroupID,fgGroupID,msglen_var + integer,dimension(:),allocatable :: cglist,fglist !(max_fg_procs) !not used ??? +!----------------------------------------------------------------------------- +! common.setup + integer,parameter :: king=0,idint=1105 + integer,parameter :: idreal=1729,idchar=1597,is_done=1 +! common/setup/ + integer :: me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,& + kolor,nfgtasks1,MyRank,kolor1,key1,max_gs_size,& + CG_COMM,FG_COMM,FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM +!el integer,dimension(:),allocatable :: koniec !(0:maxprocs-1) + integer,dimension(:),allocatable :: lentyp !(0:maxprocs-1) + integer,dimension(:),allocatable :: ifinish !(maxprocs-1) + logical :: yourjob,finished,cgdone +! common /types/ + integer :: MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2,& + MPI_THET,MPI_GAM + integer,dimension(0:1) :: MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,& + MPI_PRECOMP11,MPI_PRECOMP12,MPI_PRECOMP22,MPI_PRECOMP23 +!----------------------------------------------------------------------------- +#if defined(WHAM_RUN) || defined(CLUSTER) +! COMMON.MPI +! common /MPI_Data/ + integer :: Master,Master1,Comm1,Me1,Nprocs1,WHAM_COMM + integer,dimension(:),allocatable :: Indstart,Indend,idispl,& + scount !(0:MaxProcs) +#endif +!----------------------------------------------------------------------------- + end module MPI_data diff --git a/source/unres/data/MPI_data.f90 b/source/unres/data/MPI_data.f90 deleted file mode 100644 index 3ed522b..0000000 --- a/source/unres/data/MPI_data.f90 +++ /dev/null @@ -1,54 +0,0 @@ - module MPI_data - -!----------------------------------------------------------------------------- - integer,parameter :: max_cg_procs=2048 -!----------------------------------------------------------------------------- -! commom.info -! NPROCS - total number of processors; -! MyID - processor's ID; -! MasterID - master processor's ID. - integer :: tag - integer,dimension(:),allocatable :: status !(MPI_STATUS_SIZE) -! common /info/ - integer :: myid,masterid,allgrp,dontcare,WhatsUp - logical,dimension(:),allocatable :: koniec !(0:maxprocs-1) -!el integer,dimension(:),allocatable :: ifinish !(maxprocs-1) -!... 5/12/96 - added variables for collective communication -! FGPROCS - Number of fine-grain processors per coarse-grain task; -! NCTASKS - Number of coarse-grain tasks; -! MYGROUP - label of the processor's FG group id; -! BOSSID - ID of group's master; -! FGLIST - list of group's FG processors. -! MSGLEN_VAR - length of the vector of variables passed to the fine-grain -! slave processors -! common /info1/ - integer :: fgprocs,nctasks,mygroup,bossid,cglabel,& - cgGroupID,fgGroupID,msglen_var - integer,dimension(:),allocatable :: cglist,fglist !(max_fg_procs) !not used ??? -!----------------------------------------------------------------------------- -! common.setup - integer,parameter :: king=0,idint=1105 - integer,parameter :: idreal=1729,idchar=1597,is_done=1 -! common/setup/ - integer :: me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,& - kolor,nfgtasks1,MyRank,kolor1,key1,max_gs_size,& - CG_COMM,FG_COMM,FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM -!el integer,dimension(:),allocatable :: koniec !(0:maxprocs-1) - integer,dimension(:),allocatable :: lentyp !(0:maxprocs-1) - integer,dimension(:),allocatable :: ifinish !(maxprocs-1) - logical :: yourjob,finished,cgdone -! common /types/ - integer :: MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2,& - MPI_THET,MPI_GAM - integer,dimension(0:1) :: MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,& - MPI_PRECOMP11,MPI_PRECOMP12,MPI_PRECOMP22,MPI_PRECOMP23 -!----------------------------------------------------------------------------- -#if defined(WHAM_RUN) || defined(CLUSTER) -! COMMON.MPI -! common /MPI_Data/ - integer :: Master,Master1,Comm1,Me1,Nprocs1,WHAM_COMM - integer,dimension(:),allocatable :: Indstart,Indend,idispl,& - scount !(0:MaxProcs) -#endif -!----------------------------------------------------------------------------- - end module MPI_data diff --git a/source/unres/data/REMD_data.F90 b/source/unres/data/REMD_data.F90 new file mode 100644 index 0000000..3527922 --- /dev/null +++ b/source/unres/data/REMD_data.F90 @@ -0,0 +1,26 @@ + module REMD_data +!----------------------------------------------------------------------------- +! Maximum number of conformation stored in cache on each CPU before sending +! to master; depends on nstex / ntwx ratio + integer,parameter :: max_cache_traj=10 +!----------------------------------------------------------------------------- +! commom.remd +! common /remdcommon/ + integer :: nrep,nstex,i_sync_step + real(kind=8) :: retmin,retmax + real(kind=8),dimension(:),allocatable :: remd_t !(maxprocs) + logical :: remd_tlist,remd_mlist,mremdsync,restart1file,traj1file + integer,dimension(:),allocatable :: remd_m !(maxprocs) +! common /remdrestart/ + integer(kind=2),dimension(:),allocatable :: i2rep !,i2set !(0:maxprocs) +! common /traj1cache/ + integer :: max_cache_traj_use +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: friction_force,setup_fricmat +! real(kind=8),dimension(:,:),allocatable :: ginvfric !(2*nres,2*nres) !maxres2=2*maxres +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutine: setup_fricmat +! real(kind=8),dimension(:,:),allocatable :: fcopy !(2*nres,2*nres) +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module REMD_data diff --git a/source/unres/data/REMD_data.f90 b/source/unres/data/REMD_data.f90 deleted file mode 100644 index 3527922..0000000 --- a/source/unres/data/REMD_data.f90 +++ /dev/null @@ -1,26 +0,0 @@ - module REMD_data -!----------------------------------------------------------------------------- -! Maximum number of conformation stored in cache on each CPU before sending -! to master; depends on nstex / ntwx ratio - integer,parameter :: max_cache_traj=10 -!----------------------------------------------------------------------------- -! commom.remd -! common /remdcommon/ - integer :: nrep,nstex,i_sync_step - real(kind=8) :: retmin,retmax - real(kind=8),dimension(:),allocatable :: remd_t !(maxprocs) - logical :: remd_tlist,remd_mlist,mremdsync,restart1file,traj1file - integer,dimension(:),allocatable :: remd_m !(maxprocs) -! common /remdrestart/ - integer(kind=2),dimension(:),allocatable :: i2rep !,i2set !(0:maxprocs) -! common /traj1cache/ - integer :: max_cache_traj_use -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: friction_force,setup_fricmat -! real(kind=8),dimension(:,:),allocatable :: ginvfric !(2*nres,2*nres) !maxres2=2*maxres -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutine: setup_fricmat -! real(kind=8),dimension(:,:),allocatable :: fcopy !(2*nres,2*nres) -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module REMD_data diff --git a/source/unres/data/calc_data.F90 b/source/unres/data/calc_data.F90 new file mode 100644 index 0000000..3f40fd0 --- /dev/null +++ b/source/unres/data/calc_data.F90 @@ -0,0 +1,14 @@ + module calc_data +!----------------------------------------------------------------------------- +! commom.calc common/calc/ + integer :: i,j,k,l + real(kind=8) :: rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj,& + chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12,& + om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1,& + faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2,& + sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2,& + eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,& + sigder,dsci_inv,dscj_inv + real(kind=8),dimension(3) :: erij,gg +!----------------------------------------------------------------------------- + end module calc_data diff --git a/source/unres/data/calc_data.f90 b/source/unres/data/calc_data.f90 deleted file mode 100644 index 3f40fd0..0000000 --- a/source/unres/data/calc_data.f90 +++ /dev/null @@ -1,14 +0,0 @@ - module calc_data -!----------------------------------------------------------------------------- -! commom.calc common/calc/ - integer :: i,j,k,l - real(kind=8) :: rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj,& - chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12,& - om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1,& - faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2,& - sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2,& - eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,& - sigder,dsci_inv,dscj_inv - real(kind=8),dimension(3) :: erij,gg -!----------------------------------------------------------------------------- - end module calc_data diff --git a/source/unres/data/comm_local.F90 b/source/unres/data/comm_local.F90 new file mode 100644 index 0000000..ad29715 --- /dev/null +++ b/source/unres/data/comm_local.F90 @@ -0,0 +1,103 @@ + module comm_locel +! commom /locel/ + + integer :: num_conti,j1,j2 + real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& + dz_normi,xmedi,ymedi,zmedi + real(kind=8),dimension(2,2) :: a_temp + real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 + + end module comm_locel +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_calcthet +! commom /calcthet/ + integer :: it + real(kind=8) :: term1,term2,termm,diffak,ratak,& + ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& + delthe0,sig0inv,sigtc,sigsqtc,delthec + end module comm_calcthet +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_sccalc +! commom /sccalc/ + integer :: it,nlobit + real(kind=8) :: time11,time12,time112,theti + end module comm_sccalc +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_chu +! common /chuju/ + integer :: jjj + end module comm_chu +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_gucio +! common /gucio/ + real(kind=8),dimension(3) :: cm + end module comm_gucio +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_cipiszcze +! common /cipiszcze/ + integer :: itt_comm + end module comm_cipiszcze +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_przech +! common /przechowalnia/ + integer :: nbond + end module comm_przech +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_iofile +! common /IOFILE/ + integer :: IODA(400) + integer :: IR,IW,IP,IJK,IPK,IDAF,NAV + end module comm_iofile +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_machsw +! common /MACHSW/ + integer :: KDIAG,ICORFL,IXDR + end module comm_machsw +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_par +! common /PAR / + LOGICAL :: GOPARR,DSKWRK,MASWRK + integer :: ME,MASTER,NPROC,IBTYP,IPTIM + end module comm_par +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_srutu +! common /srutu/ + integer :: icall + end module comm_srutu +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_vrandd +! common /VRANDD/ + integer,dimension(250) :: A + integer :: I,I147 + end module comm_vrandd +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_kut +! common /kutas/ + logical :: lprn + end module comm_kut +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + module comm_syfek +! common /syfek/ +! in subroutines: friction_force,setup_fricmat + real(kind=8),dimension(:),allocatable :: gamvec !(MAXRES6) or (MAXRES2) + end module comm_syfek +!----------------------------------------------------------------------------- + module comm_sschecks +! common /sschecks/ checkstop,transgrad + logical :: checkstop,transgrad + end module comm_sschecks +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- diff --git a/source/unres/data/comm_local.f90 b/source/unres/data/comm_local.f90 deleted file mode 100644 index ad29715..0000000 --- a/source/unres/data/comm_local.f90 +++ /dev/null @@ -1,103 +0,0 @@ - module comm_locel -! commom /locel/ - - integer :: num_conti,j1,j2 - real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& - dz_normi,xmedi,ymedi,zmedi - real(kind=8),dimension(2,2) :: a_temp - real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 - - end module comm_locel -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_calcthet -! commom /calcthet/ - integer :: it - real(kind=8) :: term1,term2,termm,diffak,ratak,& - ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& - delthe0,sig0inv,sigtc,sigsqtc,delthec - end module comm_calcthet -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_sccalc -! commom /sccalc/ - integer :: it,nlobit - real(kind=8) :: time11,time12,time112,theti - end module comm_sccalc -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_chu -! common /chuju/ - integer :: jjj - end module comm_chu -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_gucio -! common /gucio/ - real(kind=8),dimension(3) :: cm - end module comm_gucio -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_cipiszcze -! common /cipiszcze/ - integer :: itt_comm - end module comm_cipiszcze -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_przech -! common /przechowalnia/ - integer :: nbond - end module comm_przech -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_iofile -! common /IOFILE/ - integer :: IODA(400) - integer :: IR,IW,IP,IJK,IPK,IDAF,NAV - end module comm_iofile -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_machsw -! common /MACHSW/ - integer :: KDIAG,ICORFL,IXDR - end module comm_machsw -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_par -! common /PAR / - LOGICAL :: GOPARR,DSKWRK,MASWRK - integer :: ME,MASTER,NPROC,IBTYP,IPTIM - end module comm_par -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_srutu -! common /srutu/ - integer :: icall - end module comm_srutu -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_vrandd -! common /VRANDD/ - integer,dimension(250) :: A - integer :: I,I147 - end module comm_vrandd -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_kut -! common /kutas/ - logical :: lprn - end module comm_kut -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - module comm_syfek -! common /syfek/ -! in subroutines: friction_force,setup_fricmat - real(kind=8),dimension(:),allocatable :: gamvec !(MAXRES6) or (MAXRES2) - end module comm_syfek -!----------------------------------------------------------------------------- - module comm_sschecks -! common /sschecks/ checkstop,transgrad - logical :: checkstop,transgrad - end module comm_sschecks -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- diff --git a/source/unres/data/compare_data.F90 b/source/unres/data/compare_data.F90 new file mode 100644 index 0000000..e17790f --- /dev/null +++ b/source/unres/data/compare_data.F90 @@ -0,0 +1,51 @@ + module compare_data +!----------------------------------------------------------------------------- +! Max. number of threading attempts + integer,parameter :: maxthread=20 +!----------------------------------------------------------------------------- +! Max. number of residues in a peptide in the database + integer,parameter :: maxres_base=10 +!----------------------------------------------------------------------------- +! commom.chain +! common /from_zscore/ + integer :: nz_start,nz_end,iz_sc +!----------------------------------------------------------------------------- +! common.dbase +! common /struct/ + real(kind=8),dimension(:,:,:),allocatable :: cart_base !(3,maxres_base,maxseq) + integer,dimension(:,:),allocatable :: nres_base !(3,maxseq) + integer :: nseq + character(len=8),dimension(:),allocatable :: str_nam !(maxseq) +!----------------------------------------------------------------------------- +! common.distfit +! parameter (maxres22=maxres*(maxres+1)/2) +! integer, parameter :: maxres22=1 + integer :: maxres22 +! COMMON /c_frag/ + integer :: nbfrag,nhfrag + integer,dimension(:,:),allocatable :: bfrag !(4,maxres/3) + integer,dimension(:,:),allocatable :: hfrag !(2,maxres/3) +! COMMON /frag/ in module CSA +! COMMON /WAGI/ + real(kind=8),dimension(:),allocatable :: w,d0 +! COMMON /POCHODNE/ + integer :: NX,NY + real(kind=8),dimension(:,:),allocatable :: DRDG !(MAXRES22,MAXRES) + real(kind=8),dimension(:),allocatable :: DDD !(maxres22) + real(kind=8),dimension(:,:),allocatable :: H !(MAXRES,MAXRES) + real(kind=8),dimension(:),allocatable :: XX !(MAXRES) +! COMMON /frozen/ + integer,dimension(:),allocatable :: mask !(maxres) +! COMMON /store0/ + integer :: nhpb0 +!----------------------------------------------------------------------------- +! common.thread +! common /thread/ + integer :: nthread,nexcl + integer,dimension(:,:),allocatable :: iexam,ipatt !(2,maxthread) +! common /thread1/ + real(kind=8),dimension(:,:),allocatable :: ener0,ener !(n_ene+2,maxthread) + real(kind=8) :: max_time_for_thread,ave_time_for_thread +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module compare_data diff --git a/source/unres/data/compare_data.f90 b/source/unres/data/compare_data.f90 deleted file mode 100644 index e17790f..0000000 --- a/source/unres/data/compare_data.f90 +++ /dev/null @@ -1,51 +0,0 @@ - module compare_data -!----------------------------------------------------------------------------- -! Max. number of threading attempts - integer,parameter :: maxthread=20 -!----------------------------------------------------------------------------- -! Max. number of residues in a peptide in the database - integer,parameter :: maxres_base=10 -!----------------------------------------------------------------------------- -! commom.chain -! common /from_zscore/ - integer :: nz_start,nz_end,iz_sc -!----------------------------------------------------------------------------- -! common.dbase -! common /struct/ - real(kind=8),dimension(:,:,:),allocatable :: cart_base !(3,maxres_base,maxseq) - integer,dimension(:,:),allocatable :: nres_base !(3,maxseq) - integer :: nseq - character(len=8),dimension(:),allocatable :: str_nam !(maxseq) -!----------------------------------------------------------------------------- -! common.distfit -! parameter (maxres22=maxres*(maxres+1)/2) -! integer, parameter :: maxres22=1 - integer :: maxres22 -! COMMON /c_frag/ - integer :: nbfrag,nhfrag - integer,dimension(:,:),allocatable :: bfrag !(4,maxres/3) - integer,dimension(:,:),allocatable :: hfrag !(2,maxres/3) -! COMMON /frag/ in module CSA -! COMMON /WAGI/ - real(kind=8),dimension(:),allocatable :: w,d0 -! COMMON /POCHODNE/ - integer :: NX,NY - real(kind=8),dimension(:,:),allocatable :: DRDG !(MAXRES22,MAXRES) - real(kind=8),dimension(:),allocatable :: DDD !(maxres22) - real(kind=8),dimension(:,:),allocatable :: H !(MAXRES,MAXRES) - real(kind=8),dimension(:),allocatable :: XX !(MAXRES) -! COMMON /frozen/ - integer,dimension(:),allocatable :: mask !(maxres) -! COMMON /store0/ - integer :: nhpb0 -!----------------------------------------------------------------------------- -! common.thread -! common /thread/ - integer :: nthread,nexcl - integer,dimension(:,:),allocatable :: iexam,ipatt !(2,maxthread) -! common /thread1/ - real(kind=8),dimension(:,:),allocatable :: ener0,ener !(n_ene+2,maxthread) - real(kind=8) :: max_time_for_thread,ave_time_for_thread -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module compare_data diff --git a/source/unres/data/control_data.F90 b/source/unres/data/control_data.F90 new file mode 100644 index 0000000..6ec06d0 --- /dev/null +++ b/source/unres/data/control_data.F90 @@ -0,0 +1,92 @@ + module control_data +!----------------------------------------------------------------------------- +! Max. number of types of dihedral angles & multiplicity of torsional barriers +! and the number of terms in double torsionals + integer,parameter :: maxtor=4,maxterm=10,maxlor=3 + integer,parameter :: maxtermd_1=8,maxtermd_2=8 +!----------------------------------------------------------------------------- +! Max. number of groups of interactions that a given SC is involved in + integer,parameter :: maxint_gr=2 +!----------------------------------------------------------------------------- +! Max. number of residue types and parameters in expressions for +! virtual-bond angle bending potentials + integer,parameter :: maxthetyp=3,maxthetyp1=maxthetyp+1 + integer,parameter :: maxtheterm=20 + integer,parameter :: maxtheterm2=6,maxtheterm3=4 + integer,parameter :: maxsingle=6,maxdouble=4 + integer,parameter :: mmaxtheterm=maxtheterm +!----------------------------------------------------------------------------- +! Max number of torsional terms in SCCOR + integer,parameter :: maxterm_sccor=7000 +!----------------------------------------------------------------------------- +! Max. number of lobes in SC distribution +! integer,parameter :: maxlob=4 in geometry +!----------------------------------------------------------------------------- +! Max. number of S-S bridges + integer,parameter :: maxss=20 +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! commom.control +! common /cntrl/ + integer :: modecalc,iscode,indpdb,indback,indphi,iranconf,& + icheckgrad,iprint,i2ndstr,mucadyn,constr_dist,symetr + logical :: minim,refstr,pdbref,overlapsc,& + energy_dec,sideadd,lsecondary,read_cart,unres_pdb,& + vdisulf,searchsc,lmuca,dccart,extconf,out1file,& + gnorm_check,gradout,split_ene +#ifdef CLUSTER + integer :: iopt,nend,nstart,outpdb,outmol2 !cluster + logical :: punch_dist,print_dist,lside,lprint_cart,lprint_int,& + caonly,efree,from_bx,from_cx,from_cart ! cluster +#else + logical :: outpdb,outmol2 +#endif +!... minim = .true. means DO minimization. +!... energy_dec = .true. means print energy decomposition matrix +!----------------------------------------------------------------------------- +! common.header +! common /header/ + character(len=80) :: titel +!----------------------------------------------------------------------------- +! common.spitele +! common /splitele/ + real(kind=8) :: r_cut,rlamb +!----------------------------------------------------------------------------- +! common.time1 +! FOUND_NAN - set by calcf to stop sumsl via stopx +! COMMON/TIME1/ + real(kind=8) :: TIMLIM,SAFETY,WALLTIME +! common /timing/ + real(kind=8) :: t_eelecij,t_enegrad,t_MDsetup,t_langsetup,t_MD,& + t_sdsetup,time_stoch,time_fric,time_fsample,time_sumene,& + time_enecalc,time_vec,time_bcast,time_reduce,time_gather,& + time_sendrecv,time_barrier_e,time_barrier_g,time_scatter,& + time_ginvmult,time_bcast7,time_bcastc,time_bcastw,& + 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 +#if defined(WHAM_RUN) || defined(CLUSTER) +! common /stoptim/ +!el integer :: WhatsUp,ndelta + integer :: ndelta + logical :: cutoffviol,cutoffeval,llocal +! common /timing/ wham +! Timers and counters for the respective routines + real(kind=8) :: t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,& + t_viol,t_gviol,t_map,t_alamap,t_betamap + integer :: n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,& + n_gviol,n_map,n_alamap,n_betamap +#endif +!----------------------------------------------------------------------------- + integer,parameter :: MaxMoveType = 4 +!----------------------------------------------------------------------------- +! Max. number of processors. + integer,parameter :: maxprocs=2048 +!el integer,parameter :: maxprocs=4200 +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module control_data diff --git a/source/unres/data/control_data.f90 b/source/unres/data/control_data.f90 deleted file mode 100644 index 6ec06d0..0000000 --- a/source/unres/data/control_data.f90 +++ /dev/null @@ -1,92 +0,0 @@ - module control_data -!----------------------------------------------------------------------------- -! Max. number of types of dihedral angles & multiplicity of torsional barriers -! and the number of terms in double torsionals - integer,parameter :: maxtor=4,maxterm=10,maxlor=3 - integer,parameter :: maxtermd_1=8,maxtermd_2=8 -!----------------------------------------------------------------------------- -! Max. number of groups of interactions that a given SC is involved in - integer,parameter :: maxint_gr=2 -!----------------------------------------------------------------------------- -! Max. number of residue types and parameters in expressions for -! virtual-bond angle bending potentials - integer,parameter :: maxthetyp=3,maxthetyp1=maxthetyp+1 - integer,parameter :: maxtheterm=20 - integer,parameter :: maxtheterm2=6,maxtheterm3=4 - integer,parameter :: maxsingle=6,maxdouble=4 - integer,parameter :: mmaxtheterm=maxtheterm -!----------------------------------------------------------------------------- -! Max number of torsional terms in SCCOR - integer,parameter :: maxterm_sccor=7000 -!----------------------------------------------------------------------------- -! Max. number of lobes in SC distribution -! integer,parameter :: maxlob=4 in geometry -!----------------------------------------------------------------------------- -! Max. number of S-S bridges - integer,parameter :: maxss=20 -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! commom.control -! common /cntrl/ - integer :: modecalc,iscode,indpdb,indback,indphi,iranconf,& - icheckgrad,iprint,i2ndstr,mucadyn,constr_dist,symetr - logical :: minim,refstr,pdbref,overlapsc,& - energy_dec,sideadd,lsecondary,read_cart,unres_pdb,& - vdisulf,searchsc,lmuca,dccart,extconf,out1file,& - gnorm_check,gradout,split_ene -#ifdef CLUSTER - integer :: iopt,nend,nstart,outpdb,outmol2 !cluster - logical :: punch_dist,print_dist,lside,lprint_cart,lprint_int,& - caonly,efree,from_bx,from_cx,from_cart ! cluster -#else - logical :: outpdb,outmol2 -#endif -!... minim = .true. means DO minimization. -!... energy_dec = .true. means print energy decomposition matrix -!----------------------------------------------------------------------------- -! common.header -! common /header/ - character(len=80) :: titel -!----------------------------------------------------------------------------- -! common.spitele -! common /splitele/ - real(kind=8) :: r_cut,rlamb -!----------------------------------------------------------------------------- -! common.time1 -! FOUND_NAN - set by calcf to stop sumsl via stopx -! COMMON/TIME1/ - real(kind=8) :: TIMLIM,SAFETY,WALLTIME -! common /timing/ - real(kind=8) :: t_eelecij,t_enegrad,t_MDsetup,t_langsetup,t_MD,& - t_sdsetup,time_stoch,time_fric,time_fsample,time_sumene,& - time_enecalc,time_vec,time_bcast,time_reduce,time_gather,& - time_sendrecv,time_barrier_e,time_barrier_g,time_scatter,& - time_ginvmult,time_bcast7,time_bcastc,time_bcastw,& - 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 -#if defined(WHAM_RUN) || defined(CLUSTER) -! common /stoptim/ -!el integer :: WhatsUp,ndelta - integer :: ndelta - logical :: cutoffviol,cutoffeval,llocal -! common /timing/ wham -! Timers and counters for the respective routines - real(kind=8) :: t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,& - t_viol,t_gviol,t_map,t_alamap,t_betamap - integer :: n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,& - n_gviol,n_map,n_alamap,n_betamap -#endif -!----------------------------------------------------------------------------- - integer,parameter :: MaxMoveType = 4 -!----------------------------------------------------------------------------- -! Max. number of processors. - integer,parameter :: maxprocs=2048 -!el integer,parameter :: maxprocs=4200 -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module control_data diff --git a/source/unres/data/energy_data.F90 b/source/unres/data/energy_data.F90 new file mode 100644 index 0000000..11382e2 --- /dev/null +++ b/source/unres/data/energy_data.F90 @@ -0,0 +1,278 @@ + module energy_data +!----------------------------------------------------------------------------- + use names +!----------------------------------------------------------------------------- +! Max. number of energy intervals + integer,parameter :: max_ene=21 !10 +!----------------------------------------------------------------------------- +! Maximum number of terms in SC bond-stretching potential + integer,parameter :: maxbondterm=3 +!----------------------------------------------------------------------------- +! Max. number of derivatives of virtual-bond and side-chain vectors in theta +! or phi. + integer :: maxdim +!----------------------------------------------------------------------------- +! Max. number of contacts per residue + integer :: maxconts +!----------------------------------------------------------------------------- +! Max. number of SC contacts + integer :: maxcont +!----------------------------------------------------------------------------- +! commom.contacts +! common /contacts/ + integer :: ncont,ncont_ref + integer,dimension(:,:),allocatable :: icont,icont_ref !(2,maxcont) +!#ifdef WHAM_RUN +! integer,dimension(:),allocatable :: nsccont_frag_ref !(mmaxfrag) !wham +! integer,dimension(:,:,:),allocatable :: isccont_frag_ref !(2,maxcont,mmaxfrag) !wham +!#endif +! 12/13/2008 (again Poland-Jaruzel war anniversary) +! RE: Parallelization of 4th and higher order loc-el correlations +! common /contdistrib/ + integer,dimension(:),allocatable :: iat_sent !(maxres) +! iat_sent - zainicjowane w initialize_p.F; + integer,dimension(:,:,:),allocatable :: iint_sent,iint_sent_local !(4,maxres,maxres) + integer,dimension(:,:),allocatable :: iturn3_sent,iturn4_sent,& + iturn3_sent_local,iturn4_sent_local !(4,maxres), + integer,dimension(:),allocatable :: itask_cont_from,itask_cont_to !(0:max_fg_procs-1), + integer :: nat_sent,ntask_cont_from,ntask_cont_to +!----------------------------------------------------------------------------- +! commom.deriv; +! common /derivat/ + real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim) + real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres) + real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2) + real(kind=8),dimension(:,:),allocatable :: gvdwx !(3,maxres) + real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2) ,gloc_x !!! nie używane + real(kind=8),dimension(:,:,:),allocatable :: dtheta !(3,2,maxres) + real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres) + integer :: nfl,icg + +! common /derivat/ wham + logical :: calc_grad +! common /mpgrad/ + integer :: igrad_start,igrad_end + integer,dimension(:),allocatable :: jgrad_start,jgrad_end !(maxres) +!----------------------------------------------------------------------------- +! The following COMMON block selects the type of the force field used in +! calculations and defines weights of various energy terms. +! 12/1/95 wcorr added +!----------------------------------------------------------------------------- +! common.ffield +! common /ffield/ + integer :: n_ene_comp + integer :: rescale_mode + real(kind=8) :: wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang,& + wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,& + wturn6,wvdwpp +#ifdef CLUSTER + real(kind=8) :: scalscp +#endif + real(kind=8),dimension(:),allocatable :: weights !(n_ene) + real(kind=8) :: temp0,scal14,cutoff_corr,delt_corr,r0_corr + integer :: ipot +! common /potentials/ + character(len=3),dimension(5) :: potname = & + (/'LJ ','LJK','BP ','GB ','GBV'/) +!----------------------------------------------------------------------------- +! wlong,welec,wtor,wang,wscloc are the weight of the energy terms +! corresponding to side-chain, electrostatic, torsional, valence-angle, +! and local side-chain terms. +! +! IPOT determines which SC...SC interaction potential will be used: +! 1 - LJ: 2n-n Lennard-Jones +! 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) +! 3 - BP; Berne-Pechukas (angular dependence) +! 4 - GB; Gay-Berne (angular dependence) +! 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential +!----------------------------------------------------------------------------- +! common.interact +! common /interact/ + real(kind=8),dimension(:,:),allocatable :: aa,bb,augm !(ntyp,ntyp) + real(kind=8),dimension(:,:),allocatable :: aad,bad !(ntyp,2) + real(kind=8),dimension(2,2) :: app,bpp,ael6,ael3 + integer :: expon,expon2, nnt,nct,itypro + integer,dimension(:,:),allocatable :: istart,iend !(maxres,maxint_gr) + integer,dimension(:),allocatable :: nint_gr,itype,itel,& + ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr !(maxres) + integer,dimension(:,:),allocatable :: iscpstart,iscpend !(maxres,maxint_gr) + integer :: iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,& + iatel_e_vdw,iatscp_s,iatscp_e,ispp,iscp +! 12/1/95 Array EPS included in the COMMON block. +! common /body/ + real(kind=8),dimension(:,:),allocatable :: sigma !(0:ntyp1,0:ntyp1) + real(kind=8),dimension(:,:),allocatable :: eps,sigmaii,& + rs0,chi,r0,r0e !(ntyp,ntyp) r0e !!! nie używane + real(kind=8),dimension(:),allocatable :: chip,alp,sigma0,& + sigii,rr0 !(ntyp) + real(kind=8),dimension(2,2) :: rpp,epp,elpp6,elpp3 + real(kind=8),dimension(:,:),allocatable :: r0d,eps_scp,rscp !(ntyp,2) r0d !!! nie używane +! 12/5/03 modified 09/18/03 Bond stretching parameters. +! common /stretch/ + real(kind=8) :: vbldp0,akp,distchainmax + real(kind=8),dimension(:,:),allocatable :: vbldsc0,aksc,abond0 !(maxbondterm,ntyp) + integer,dimension(:),allocatable :: nbondterm !(ntyp) +!----------------------------------------------------------------------------- +! common.local +! Parameters of ab initio-derived potential of virtual-bond-angle bending +! common /theta_abinitio/ + integer :: nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,& + ndouble,nntheterm + integer,dimension(:),allocatable :: ithetyp !(-ntyp1:ntyp1) + real(kind=8),dimension(:,:,:,:),allocatable :: aa0thet +!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + real(kind=8),dimension(:,:,:,:,:),allocatable :: aathet + real(kind=8),dimension(:,:,:,:,:,:),allocatable :: bbthet,& + ccthet,ddthet,eethet +!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: ffthet,ggthet +!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) +! Parameters of the virtual-bond-angle probability distribution +! common /thetas/ + real(kind=8),dimension(:),allocatable :: a0thet,theta0,& + sig0,sigc0 !(-ntyp:ntyp) + real(kind=8),dimension(:,:,:,:),allocatable :: athet,bthet !(2,-ntyp:ntyp,-1:1,-1:1) + real(kind=8),dimension(:,:),allocatable :: polthet !(0:3,-ntyp:ntyp) + real(kind=8),dimension(:,:),allocatable :: gthet !(3,-ntyp:ntyp) +! Parameters of the side-chain probability distribution +! common /sclocal/ + real(kind=8),dimension(:),allocatable :: dsc,dsc_inv,dsc0 !(ntyp1) + real(kind=8),dimension(:,:),allocatable :: bsc !(maxlob,ntyp) + real(kind=8),dimension(:,:,:),allocatable :: censc !(3,maxlob,-ntyp:ntyp) + real(kind=8),dimension(:,:,:,:),allocatable :: gaussc !(3,3,maxlob,-ntyp:ntyp) + integer,dimension(:),allocatable :: nlob !(ntyp1) +! Virtual-bond lenghts +! common /peptbond/ + real(kind=8) :: vbl,vblinv,vblinv2,vbl_cis,vbl0 +! common /indices/ + integer :: loc_start,loc_end,ithet_start,ithet_end,iphi_start,& + iphi_end,iphid_start,iphid_end,ibond_start,ibond_end,& + ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end,& + iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start,& + iint_end,iphi1_start,iphi1_end,itau_start,itau_end + integer,dimension(:),allocatable :: ibond_displ,ibond_count,& + ithet_displ,ithet_count,iphi_displ,iphi_count,iphi1_displ,& + iphi1_count,ivec_displ,ivec_count,iset_displ,iset_count,& + iint_count,iint_displ !(0:max_fg_procs-1) +!----------------------------------------------------------------------------- +! common.MD +! common /mdgrad/ + real(kind=8),dimension(:,:),allocatable :: gcart,gxcart !(3,0:MAXRES) + real(kind=8),dimension(:,:),allocatable :: gradcag,gradxag !(3,MAXRES) !!! nie używane +! common /back_constr/ + integer :: nfrag_back + real(kind=8) :: uconst_back + real(kind=8),dimension(:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back) + real(kind=8),dimension(:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20) + integer,dimension(:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20) +! common /qmeas/ + real(kind=8),dimension(50) :: qfrag + real(kind=8),dimension(100) :: qpair + real(kind=8),dimension(:,:),allocatable :: qinfrag,wfrag !(50,maxprocs/20) + real(kind=8),dimension(:,:),allocatable :: qinpair,wpair !(100,maxprocs/20) + real(kind=8) :: eq_time,Uconst + integer :: iset,nset + integer,dimension(:),allocatable :: mset !(maxprocs/20) + integer,dimension(:,:,:),allocatable :: ifrag !(2,50,maxprocs/20) + integer,dimension(:,:,:),allocatable :: ipair !(2,100,maxprocs/20) + integer :: nfrag,npair + logical :: usampl +!----------------------------------------------------------------------------- +! common.sbridge +! common /sbridge/ + real(kind=8) :: ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss + integer :: ns,nss,nfree + integer,dimension(:),allocatable :: iss !(maxss) +! common /links/ + real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane + integer :: nhpb + integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane +! common /restraints/ + real(kind=8) :: weidis +! common /links_split/ + integer :: link_start,link_end +! common /dyn_ssbond/ + real(kind=8) :: Ht + integer,dimension(:),allocatable :: idssb,jdssb !(maxdim) + logical :: dyn_ss + logical,dimension(:),allocatable :: dyn_ss_mask !(maxres) +!----------------------------------------------------------------------------- +! common.sccor +! Parameters of the SCCOR term +! common/sccor/ + real(kind=8),dimension(:,:,:,:),allocatable :: v1sccor,v2sccor !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) + real(kind=8),dimension(:,:,:),allocatable :: v0sccor !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) + integer :: nsccortyp + integer,dimension(:),allocatable :: isccortyp !(-ntyp:ntyp) + integer,dimension(:,:),allocatable :: nterm_sccor,nlor_sccor !(-ntyp:ntyp,-ntyp:ntyp) + real(kind=8),dimension(:,:,:),allocatable :: vlor1sccor,& + vlor2sccor,vlor3sccor !(maxterm_sccor,20,20) + real(kind=8),dimension(:,:,:),allocatable :: gloc_sc !(3,0:maxres2,10) + real(kind=8),dimension(:,:,:,:),allocatable :: dtauangle !(3,3,3,maxres2) +!----------------------------------------------------------------------------- +! common.scrot +! Parameters of the SC rotamers (local) term +! common/scrot/ + real(kind=8),dimension(:,:),allocatable :: sc_parmin !(maxsccoef,ntyp) +!----------------------------------------------------------------------------- +! common.torcnstr +! common /torcnstr/ + integer :: ndih_constr,ndih_nconstr + integer,dimension(:),allocatable :: idih_constr,idih_nconstr !(maxdih_constr) + integer :: idihconstr_start,idihconstr_end + real(kind=8) :: ftors + real(kind=8),dimension(:),allocatable :: drange !(maxdih_constr) + real(kind=8),dimension(:),allocatable :: phi0 !(maxdih_constr) +!----------------------------------------------------------------------------- +! common.torsion +! Torsional constants of the rotation about virtual-bond dihedral angles +! common/torsion/ + real(kind=8),dimension(:,:,:),allocatable :: v0 !(-maxtor:maxtor,-maxtor:maxtor,2) +#ifdef CRYST_TOR + real(kind=8),dimension(:,:,:),allocatable :: v1,v2 !(maxterm,-maxtor:maxtor,-maxtor:maxtor) +#else + real(kind=8),dimension(:,:,:,:),allocatable :: v1,v2 !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) +#endif + real(kind=8),dimension(:,:,:),allocatable :: vlor1 !(maxlor,-maxtor:maxtor,-maxtor:maxtor) + real(kind=8),dimension(:,:,:),allocatable :: vlor2,vlor3 !(maxlor,maxtor,maxtor) + integer,dimension(:),allocatable :: itortyp !(-ntyp1:ntyp1) + integer,dimension(:,:,:),allocatable :: nterm,nlor !(-maxtor:maxtor,-maxtor:maxtor,2) + integer :: ntortyp,nterm_old +! 6/23/01 - constants for double torsionals +! common /torsiond/ + real(kind=8),dimension(:,:,:,:,:,:),allocatable :: v1c,v1s + !(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) + real(kind=8),dimension(:,:,:,:,:,:),allocatable :: v2c,v2s + !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) + integer,dimension(:,:,:,:),allocatable :: ntermd_1,ntermd_2 + !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +! 9/18/99 - added Fourier coeffficients of the expansion of local energy +! surfacecommon +! common/fourier/ + real(kind=8),dimension(:,:),allocatable :: b1,b2,& + b1tilde !(2,-maxtor:maxtor), + real(kind=8),dimension(:,:,:),allocatable :: cc,dd,ee,& + ctilde,dtilde !(2,2,-maxtor:maxtor) + integer :: nloctyp +! common/fourier/ z wham + real(kind=8),dimension(:,:),allocatable :: b !(13,0:maxtor) +!----------------------------------------------------------------------------- +! common.var +! Store the geometric variables in the following COMMON block. +! common /var/ in module geometry_data +! Store the angles and variables corresponding to old conformations (for use +! in MCM). +! common /oldgeo/ +!el real(kind=8),dimension(:,:),allocatable :: varsave !(maxvar,maxsave) +! real(kind=8),dimension(:),allocatable :: esave !(maxsave) +! integer,dimension(:),allocatable :: Origin !(maxsave) +! integer :: nstore +! freeze some variables +! common /restr/ + real(kind=8),dimension(:),allocatable :: varall !(maxvar) + integer,dimension(:),allocatable :: mask_theta,& + mask_phi,mask_side !(maxres) + logical :: mask_r +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module energy_data diff --git a/source/unres/data/energy_data.f90 b/source/unres/data/energy_data.f90 deleted file mode 100644 index 11382e2..0000000 --- a/source/unres/data/energy_data.f90 +++ /dev/null @@ -1,278 +0,0 @@ - module energy_data -!----------------------------------------------------------------------------- - use names -!----------------------------------------------------------------------------- -! Max. number of energy intervals - integer,parameter :: max_ene=21 !10 -!----------------------------------------------------------------------------- -! Maximum number of terms in SC bond-stretching potential - integer,parameter :: maxbondterm=3 -!----------------------------------------------------------------------------- -! Max. number of derivatives of virtual-bond and side-chain vectors in theta -! or phi. - integer :: maxdim -!----------------------------------------------------------------------------- -! Max. number of contacts per residue - integer :: maxconts -!----------------------------------------------------------------------------- -! Max. number of SC contacts - integer :: maxcont -!----------------------------------------------------------------------------- -! commom.contacts -! common /contacts/ - integer :: ncont,ncont_ref - integer,dimension(:,:),allocatable :: icont,icont_ref !(2,maxcont) -!#ifdef WHAM_RUN -! integer,dimension(:),allocatable :: nsccont_frag_ref !(mmaxfrag) !wham -! integer,dimension(:,:,:),allocatable :: isccont_frag_ref !(2,maxcont,mmaxfrag) !wham -!#endif -! 12/13/2008 (again Poland-Jaruzel war anniversary) -! RE: Parallelization of 4th and higher order loc-el correlations -! common /contdistrib/ - integer,dimension(:),allocatable :: iat_sent !(maxres) -! iat_sent - zainicjowane w initialize_p.F; - integer,dimension(:,:,:),allocatable :: iint_sent,iint_sent_local !(4,maxres,maxres) - integer,dimension(:,:),allocatable :: iturn3_sent,iturn4_sent,& - iturn3_sent_local,iturn4_sent_local !(4,maxres), - integer,dimension(:),allocatable :: itask_cont_from,itask_cont_to !(0:max_fg_procs-1), - integer :: nat_sent,ntask_cont_from,ntask_cont_to -!----------------------------------------------------------------------------- -! commom.deriv; -! common /derivat/ - real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim) - real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres) - real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2) - real(kind=8),dimension(:,:),allocatable :: gvdwx !(3,maxres) - real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2) ,gloc_x !!! nie używane - real(kind=8),dimension(:,:,:),allocatable :: dtheta !(3,2,maxres) - real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres) - integer :: nfl,icg - -! common /derivat/ wham - logical :: calc_grad -! common /mpgrad/ - integer :: igrad_start,igrad_end - integer,dimension(:),allocatable :: jgrad_start,jgrad_end !(maxres) -!----------------------------------------------------------------------------- -! The following COMMON block selects the type of the force field used in -! calculations and defines weights of various energy terms. -! 12/1/95 wcorr added -!----------------------------------------------------------------------------- -! common.ffield -! common /ffield/ - integer :: n_ene_comp - integer :: rescale_mode - real(kind=8) :: wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang,& - wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,& - wturn6,wvdwpp -#ifdef CLUSTER - real(kind=8) :: scalscp -#endif - real(kind=8),dimension(:),allocatable :: weights !(n_ene) - real(kind=8) :: temp0,scal14,cutoff_corr,delt_corr,r0_corr - integer :: ipot -! common /potentials/ - character(len=3),dimension(5) :: potname = & - (/'LJ ','LJK','BP ','GB ','GBV'/) -!----------------------------------------------------------------------------- -! wlong,welec,wtor,wang,wscloc are the weight of the energy terms -! corresponding to side-chain, electrostatic, torsional, valence-angle, -! and local side-chain terms. -! -! IPOT determines which SC...SC interaction potential will be used: -! 1 - LJ: 2n-n Lennard-Jones -! 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) -! 3 - BP; Berne-Pechukas (angular dependence) -! 4 - GB; Gay-Berne (angular dependence) -! 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential -!----------------------------------------------------------------------------- -! common.interact -! common /interact/ - real(kind=8),dimension(:,:),allocatable :: aa,bb,augm !(ntyp,ntyp) - real(kind=8),dimension(:,:),allocatable :: aad,bad !(ntyp,2) - real(kind=8),dimension(2,2) :: app,bpp,ael6,ael3 - integer :: expon,expon2, nnt,nct,itypro - integer,dimension(:,:),allocatable :: istart,iend !(maxres,maxint_gr) - integer,dimension(:),allocatable :: nint_gr,itype,itel,& - ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr !(maxres) - integer,dimension(:,:),allocatable :: iscpstart,iscpend !(maxres,maxint_gr) - integer :: iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,& - iatel_e_vdw,iatscp_s,iatscp_e,ispp,iscp -! 12/1/95 Array EPS included in the COMMON block. -! common /body/ - real(kind=8),dimension(:,:),allocatable :: sigma !(0:ntyp1,0:ntyp1) - real(kind=8),dimension(:,:),allocatable :: eps,sigmaii,& - rs0,chi,r0,r0e !(ntyp,ntyp) r0e !!! nie używane - real(kind=8),dimension(:),allocatable :: chip,alp,sigma0,& - sigii,rr0 !(ntyp) - real(kind=8),dimension(2,2) :: rpp,epp,elpp6,elpp3 - real(kind=8),dimension(:,:),allocatable :: r0d,eps_scp,rscp !(ntyp,2) r0d !!! nie używane -! 12/5/03 modified 09/18/03 Bond stretching parameters. -! common /stretch/ - real(kind=8) :: vbldp0,akp,distchainmax - real(kind=8),dimension(:,:),allocatable :: vbldsc0,aksc,abond0 !(maxbondterm,ntyp) - integer,dimension(:),allocatable :: nbondterm !(ntyp) -!----------------------------------------------------------------------------- -! common.local -! Parameters of ab initio-derived potential of virtual-bond-angle bending -! common /theta_abinitio/ - integer :: nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,& - ndouble,nntheterm - integer,dimension(:),allocatable :: ithetyp !(-ntyp1:ntyp1) - real(kind=8),dimension(:,:,:,:),allocatable :: aa0thet -!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - real(kind=8),dimension(:,:,:,:,:),allocatable :: aathet - real(kind=8),dimension(:,:,:,:,:,:),allocatable :: bbthet,& - ccthet,ddthet,eethet -!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: ffthet,ggthet -!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) -! Parameters of the virtual-bond-angle probability distribution -! common /thetas/ - real(kind=8),dimension(:),allocatable :: a0thet,theta0,& - sig0,sigc0 !(-ntyp:ntyp) - real(kind=8),dimension(:,:,:,:),allocatable :: athet,bthet !(2,-ntyp:ntyp,-1:1,-1:1) - real(kind=8),dimension(:,:),allocatable :: polthet !(0:3,-ntyp:ntyp) - real(kind=8),dimension(:,:),allocatable :: gthet !(3,-ntyp:ntyp) -! Parameters of the side-chain probability distribution -! common /sclocal/ - real(kind=8),dimension(:),allocatable :: dsc,dsc_inv,dsc0 !(ntyp1) - real(kind=8),dimension(:,:),allocatable :: bsc !(maxlob,ntyp) - real(kind=8),dimension(:,:,:),allocatable :: censc !(3,maxlob,-ntyp:ntyp) - real(kind=8),dimension(:,:,:,:),allocatable :: gaussc !(3,3,maxlob,-ntyp:ntyp) - integer,dimension(:),allocatable :: nlob !(ntyp1) -! Virtual-bond lenghts -! common /peptbond/ - real(kind=8) :: vbl,vblinv,vblinv2,vbl_cis,vbl0 -! common /indices/ - integer :: loc_start,loc_end,ithet_start,ithet_end,iphi_start,& - iphi_end,iphid_start,iphid_end,ibond_start,ibond_end,& - ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end,& - iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start,& - iint_end,iphi1_start,iphi1_end,itau_start,itau_end - integer,dimension(:),allocatable :: ibond_displ,ibond_count,& - ithet_displ,ithet_count,iphi_displ,iphi_count,iphi1_displ,& - iphi1_count,ivec_displ,ivec_count,iset_displ,iset_count,& - iint_count,iint_displ !(0:max_fg_procs-1) -!----------------------------------------------------------------------------- -! common.MD -! common /mdgrad/ - real(kind=8),dimension(:,:),allocatable :: gcart,gxcart !(3,0:MAXRES) - real(kind=8),dimension(:,:),allocatable :: gradcag,gradxag !(3,MAXRES) !!! nie używane -! common /back_constr/ - integer :: nfrag_back - real(kind=8) :: uconst_back - real(kind=8),dimension(:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back) - real(kind=8),dimension(:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20) - integer,dimension(:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20) -! common /qmeas/ - real(kind=8),dimension(50) :: qfrag - real(kind=8),dimension(100) :: qpair - real(kind=8),dimension(:,:),allocatable :: qinfrag,wfrag !(50,maxprocs/20) - real(kind=8),dimension(:,:),allocatable :: qinpair,wpair !(100,maxprocs/20) - real(kind=8) :: eq_time,Uconst - integer :: iset,nset - integer,dimension(:),allocatable :: mset !(maxprocs/20) - integer,dimension(:,:,:),allocatable :: ifrag !(2,50,maxprocs/20) - integer,dimension(:,:,:),allocatable :: ipair !(2,100,maxprocs/20) - integer :: nfrag,npair - logical :: usampl -!----------------------------------------------------------------------------- -! common.sbridge -! common /sbridge/ - real(kind=8) :: ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss - integer :: ns,nss,nfree - integer,dimension(:),allocatable :: iss !(maxss) -! common /links/ - real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane - integer :: nhpb - integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane -! common /restraints/ - real(kind=8) :: weidis -! common /links_split/ - integer :: link_start,link_end -! common /dyn_ssbond/ - real(kind=8) :: Ht - integer,dimension(:),allocatable :: idssb,jdssb !(maxdim) - logical :: dyn_ss - logical,dimension(:),allocatable :: dyn_ss_mask !(maxres) -!----------------------------------------------------------------------------- -! common.sccor -! Parameters of the SCCOR term -! common/sccor/ - real(kind=8),dimension(:,:,:,:),allocatable :: v1sccor,v2sccor !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) - real(kind=8),dimension(:,:,:),allocatable :: v0sccor !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) - integer :: nsccortyp - integer,dimension(:),allocatable :: isccortyp !(-ntyp:ntyp) - integer,dimension(:,:),allocatable :: nterm_sccor,nlor_sccor !(-ntyp:ntyp,-ntyp:ntyp) - real(kind=8),dimension(:,:,:),allocatable :: vlor1sccor,& - vlor2sccor,vlor3sccor !(maxterm_sccor,20,20) - real(kind=8),dimension(:,:,:),allocatable :: gloc_sc !(3,0:maxres2,10) - real(kind=8),dimension(:,:,:,:),allocatable :: dtauangle !(3,3,3,maxres2) -!----------------------------------------------------------------------------- -! common.scrot -! Parameters of the SC rotamers (local) term -! common/scrot/ - real(kind=8),dimension(:,:),allocatable :: sc_parmin !(maxsccoef,ntyp) -!----------------------------------------------------------------------------- -! common.torcnstr -! common /torcnstr/ - integer :: ndih_constr,ndih_nconstr - integer,dimension(:),allocatable :: idih_constr,idih_nconstr !(maxdih_constr) - integer :: idihconstr_start,idihconstr_end - real(kind=8) :: ftors - real(kind=8),dimension(:),allocatable :: drange !(maxdih_constr) - real(kind=8),dimension(:),allocatable :: phi0 !(maxdih_constr) -!----------------------------------------------------------------------------- -! common.torsion -! Torsional constants of the rotation about virtual-bond dihedral angles -! common/torsion/ - real(kind=8),dimension(:,:,:),allocatable :: v0 !(-maxtor:maxtor,-maxtor:maxtor,2) -#ifdef CRYST_TOR - real(kind=8),dimension(:,:,:),allocatable :: v1,v2 !(maxterm,-maxtor:maxtor,-maxtor:maxtor) -#else - real(kind=8),dimension(:,:,:,:),allocatable :: v1,v2 !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) -#endif - real(kind=8),dimension(:,:,:),allocatable :: vlor1 !(maxlor,-maxtor:maxtor,-maxtor:maxtor) - real(kind=8),dimension(:,:,:),allocatable :: vlor2,vlor3 !(maxlor,maxtor,maxtor) - integer,dimension(:),allocatable :: itortyp !(-ntyp1:ntyp1) - integer,dimension(:,:,:),allocatable :: nterm,nlor !(-maxtor:maxtor,-maxtor:maxtor,2) - integer :: ntortyp,nterm_old -! 6/23/01 - constants for double torsionals -! common /torsiond/ - real(kind=8),dimension(:,:,:,:,:,:),allocatable :: v1c,v1s - !(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) - real(kind=8),dimension(:,:,:,:,:,:),allocatable :: v2c,v2s - !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) - integer,dimension(:,:,:,:),allocatable :: ntermd_1,ntermd_2 - !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) -! 9/18/99 - added Fourier coeffficients of the expansion of local energy -! surfacecommon -! common/fourier/ - real(kind=8),dimension(:,:),allocatable :: b1,b2,& - b1tilde !(2,-maxtor:maxtor), - real(kind=8),dimension(:,:,:),allocatable :: cc,dd,ee,& - ctilde,dtilde !(2,2,-maxtor:maxtor) - integer :: nloctyp -! common/fourier/ z wham - real(kind=8),dimension(:,:),allocatable :: b !(13,0:maxtor) -!----------------------------------------------------------------------------- -! common.var -! Store the geometric variables in the following COMMON block. -! common /var/ in module geometry_data -! Store the angles and variables corresponding to old conformations (for use -! in MCM). -! common /oldgeo/ -!el real(kind=8),dimension(:,:),allocatable :: varsave !(maxvar,maxsave) -! real(kind=8),dimension(:),allocatable :: esave !(maxsave) -! integer,dimension(:),allocatable :: Origin !(maxsave) -! integer :: nstore -! freeze some variables -! common /restr/ - real(kind=8),dimension(:),allocatable :: varall !(maxvar) - integer,dimension(:),allocatable :: mask_theta,& - mask_phi,mask_side !(maxres) - logical :: mask_r -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module energy_data diff --git a/source/unres/data/geometry_data.F90 b/source/unres/data/geometry_data.F90 new file mode 100644 index 0000000..e6e73d2 --- /dev/null +++ b/source/unres/data/geometry_data.F90 @@ -0,0 +1,60 @@ + module geometry_data +!----------------------------------------------------------------------------- +! commom.bounds +! common /bounds/ + real(kind=8),dimension(:,:),allocatable :: phibound !(2,maxres) +!----------------------------------------------------------------------------- +! commom.chain +! common /chain/ + real(kind=8),dimension(:,:),allocatable :: c !(3,maxres2+2) + real(kind=8),dimension(:,:),allocatable :: dc,dc_old,& + dc_norm,dc_norm2 !(3,0:maxres2) + real(kind=8),dimension(:,:),allocatable :: xloc,xrot !(3,maxres) + real(kind=8),dimension(:),allocatable :: dc_work !(MAXRES6) + integer :: nres,nres0 +! common /rotmat/ + real(kind=8),dimension(:,:,:),allocatable :: prod,rt !(3,3,maxres) +! common /refstruct/ + real(kind=8),dimension(:,:,:),allocatable :: cref !(3,maxres2+2,maxperm), + real(kind=8),dimension(:,:),allocatable :: crefjlee !(3,maxres2+2), + real(kind=8),dimension(:,:,:),allocatable :: chain_rep !(3,maxres2+2,maxsym) + integer :: nsup,nstart_sup,nstart_seq,chain_length,iprzes,nperm + integer :: nend_sup,ishift_pdb !wham + real(kind=8) :: rmssing,anatemp !wham + integer,dimension(:,:),allocatable :: tabperm !(maxperm,maxsym) +! common /from_zscore/ in module.compare +!----------------------------------------------------------------------------- +! common.geo +! common /geo/ + real(kind=8) :: pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin +!----------------------------------------------------------------------------- +! common.local +! Inverses of the actual virtual bond lengths +! common /invlen/ + real(kind=8),dimension(:),allocatable :: vbld_inv !(maxres2) +!----------------------------------------------------------------------------- +! Max. number of lobes in SC distribution + integer,parameter :: maxlob=5 +!----------------------------------------------------------------------------- +! Max number of symetric chains + integer,parameter :: maxsym=50 + integer,parameter :: maxperm=120 +!----------------------------------------------------------------------------- +! common.var +! Store the geometric variables in the following COMMON block. +! common /var/ + real(kind=8),dimension(:),allocatable :: theta,phi,alph,omeg,& + thetaref,phiref,costtab,sinttab,cost2tab,sint2tab !(maxres) + real(kind=8),dimension(:),allocatable :: vbld !(2*maxres) + real(kind=8),dimension(:,:),allocatable :: omicron !(2,maxres) + real(kind=8),dimension(:,:),allocatable :: tauangle !(3,maxres) + real(kind=8),dimension(:),allocatable :: xxtab,yytab,zztab,& + xxref,yyref,zzref !(maxres) + integer,dimension(:,:),allocatable :: ialph !(maxres,2) + integer,dimension(:),allocatable :: ivar !(4*maxres2) + integer :: ntheta,nphi,nside,nvar +!----------------------------------------------------------------------------- + integer,dimension(:),allocatable :: itype_pdb !(maxres) initialize in molread +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module geometry_data diff --git a/source/unres/data/geometry_data.f90 b/source/unres/data/geometry_data.f90 deleted file mode 100644 index e6e73d2..0000000 --- a/source/unres/data/geometry_data.f90 +++ /dev/null @@ -1,60 +0,0 @@ - module geometry_data -!----------------------------------------------------------------------------- -! commom.bounds -! common /bounds/ - real(kind=8),dimension(:,:),allocatable :: phibound !(2,maxres) -!----------------------------------------------------------------------------- -! commom.chain -! common /chain/ - real(kind=8),dimension(:,:),allocatable :: c !(3,maxres2+2) - real(kind=8),dimension(:,:),allocatable :: dc,dc_old,& - dc_norm,dc_norm2 !(3,0:maxres2) - real(kind=8),dimension(:,:),allocatable :: xloc,xrot !(3,maxres) - real(kind=8),dimension(:),allocatable :: dc_work !(MAXRES6) - integer :: nres,nres0 -! common /rotmat/ - real(kind=8),dimension(:,:,:),allocatable :: prod,rt !(3,3,maxres) -! common /refstruct/ - real(kind=8),dimension(:,:,:),allocatable :: cref !(3,maxres2+2,maxperm), - real(kind=8),dimension(:,:),allocatable :: crefjlee !(3,maxres2+2), - real(kind=8),dimension(:,:,:),allocatable :: chain_rep !(3,maxres2+2,maxsym) - integer :: nsup,nstart_sup,nstart_seq,chain_length,iprzes,nperm - integer :: nend_sup,ishift_pdb !wham - real(kind=8) :: rmssing,anatemp !wham - integer,dimension(:,:),allocatable :: tabperm !(maxperm,maxsym) -! common /from_zscore/ in module.compare -!----------------------------------------------------------------------------- -! common.geo -! common /geo/ - real(kind=8) :: pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin -!----------------------------------------------------------------------------- -! common.local -! Inverses of the actual virtual bond lengths -! common /invlen/ - real(kind=8),dimension(:),allocatable :: vbld_inv !(maxres2) -!----------------------------------------------------------------------------- -! Max. number of lobes in SC distribution - integer,parameter :: maxlob=5 -!----------------------------------------------------------------------------- -! Max number of symetric chains - integer,parameter :: maxsym=50 - integer,parameter :: maxperm=120 -!----------------------------------------------------------------------------- -! common.var -! Store the geometric variables in the following COMMON block. -! common /var/ - real(kind=8),dimension(:),allocatable :: theta,phi,alph,omeg,& - thetaref,phiref,costtab,sinttab,cost2tab,sint2tab !(maxres) - real(kind=8),dimension(:),allocatable :: vbld !(2*maxres) - real(kind=8),dimension(:,:),allocatable :: omicron !(2,maxres) - real(kind=8),dimension(:,:),allocatable :: tauangle !(3,maxres) - real(kind=8),dimension(:),allocatable :: xxtab,yytab,zztab,& - xxref,yyref,zzref !(maxres) - integer,dimension(:,:),allocatable :: ialph !(maxres,2) - integer,dimension(:),allocatable :: ivar !(4*maxres2) - integer :: ntheta,nphi,nside,nvar -!----------------------------------------------------------------------------- - integer,dimension(:),allocatable :: itype_pdb !(maxres) initialize in molread -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module geometry_data diff --git a/source/unres/data/io_units.F90 b/source/unres/data/io_units.F90 new file mode 100644 index 0000000..e470892 --- /dev/null +++ b/source/unres/data/io_units.F90 @@ -0,0 +1,71 @@ + module io_units +!----------------------------------------------------------------------- +! common.iounits +! I/O units used by the program +!----------------------------------------------------------------------- +! 9/18/99 - unit ifourier and filename fouriername included to identify +! the file from which the coefficients of second-order Fourier expansion +! of the local-interaction energy are read. +! 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) +! included. +!----------------------------------------------------------------------- +! General I/O units & files +! common /iounits/ + integer :: inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam,& + itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat,ientin,& + ientout,izs1,isecpred,ibond,irest2,iifrag,icart,irest1,isccor,& + ithep_pdb,irotam_pdb +#ifdef WHAM_RUN +! el wham iounits + integer :: isidep1,ihist,iweight,izsc,idistr +#endif +#ifdef CLUSTER +! el cluster iounits + integer :: jrms,jplot +#endif +! +! common /fnames/ + character(len=256) :: outname,intname,pdbname,mol2name,statname,& + intinname,entname,prefix,secpred,rest2name,qname,cartname,& + tmpdir,mremd_rst_name,curdir,pref_orig +#ifdef CLUSTER + integer :: isidep1 + character(len=256) :: rmsname,prefintin,prefout +#endif +!#ifdef WHAM_RUN +! el wham iounits + character(len=256) :: restartnam,scratchdir,sidepname,pdbfile,& + histname,zscname + character(len=4) :: liczba + character(len=3) :: pot +!#endif +! Parameter files +! common /parfiles/ + character(len=256) :: bondname,thetname,rotname,torname,tordname,& + fouriername,elename,sidename,scpname,sccorname,patname,& + thetname_pdb,rotname_pdb +!----------------------------------------------------------------------- +! INP - main input file +! IOUT - list file +! IGEOM - geometry output in the form of virtual-chain internal coordinates +! INTIN - geometry input (for multiple conformation processing) in int. coords. +! IPDB - Cartesian-coordinate output in PDB format +! IMOL2 - Cartesian-coordinate output in Tripos mol2 format +! IPDBIN - PDB input file +! ITHEP - virtual-bond torsional angle parametrs +! IROTAM - side-chain geometry and local-interaction parameters +! ITORP - torsional parameters +! ITORDP - double torsional parameters +! IFOURIER - coefficients of the expansion of local-interaction energy +! IELEP - electrostatic-interaction parameters +! ISIDEP - side-chain interaction parameters. +! ISCPP - SCp interaction parameters. +! IBOND - virtual-bond constant parameters and moments of inertia. +! ISCCOR - parameters of the potential of SCCOR term +! ICBASE - data base with Cartesian coords of known structures. +! ISTAT - energies and other conf. characteristics from an MCM run. +! IENTIN - entropy from preceeding simulation(s) to be read in. +! SECPRED - SECONDARY STRUCTURE PREDICTION for dihedral constraint generation. +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module io_units diff --git a/source/unres/data/io_units.f90 b/source/unres/data/io_units.f90 deleted file mode 100644 index e470892..0000000 --- a/source/unres/data/io_units.f90 +++ /dev/null @@ -1,71 +0,0 @@ - module io_units -!----------------------------------------------------------------------- -! common.iounits -! I/O units used by the program -!----------------------------------------------------------------------- -! 9/18/99 - unit ifourier and filename fouriername included to identify -! the file from which the coefficients of second-order Fourier expansion -! of the local-interaction energy are read. -! 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) -! included. -!----------------------------------------------------------------------- -! General I/O units & files -! common /iounits/ - integer :: inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam,& - itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat,ientin,& - ientout,izs1,isecpred,ibond,irest2,iifrag,icart,irest1,isccor,& - ithep_pdb,irotam_pdb -#ifdef WHAM_RUN -! el wham iounits - integer :: isidep1,ihist,iweight,izsc,idistr -#endif -#ifdef CLUSTER -! el cluster iounits - integer :: jrms,jplot -#endif -! -! common /fnames/ - character(len=256) :: outname,intname,pdbname,mol2name,statname,& - intinname,entname,prefix,secpred,rest2name,qname,cartname,& - tmpdir,mremd_rst_name,curdir,pref_orig -#ifdef CLUSTER - integer :: isidep1 - character(len=256) :: rmsname,prefintin,prefout -#endif -!#ifdef WHAM_RUN -! el wham iounits - character(len=256) :: restartnam,scratchdir,sidepname,pdbfile,& - histname,zscname - character(len=4) :: liczba - character(len=3) :: pot -!#endif -! Parameter files -! common /parfiles/ - character(len=256) :: bondname,thetname,rotname,torname,tordname,& - fouriername,elename,sidename,scpname,sccorname,patname,& - thetname_pdb,rotname_pdb -!----------------------------------------------------------------------- -! INP - main input file -! IOUT - list file -! IGEOM - geometry output in the form of virtual-chain internal coordinates -! INTIN - geometry input (for multiple conformation processing) in int. coords. -! IPDB - Cartesian-coordinate output in PDB format -! IMOL2 - Cartesian-coordinate output in Tripos mol2 format -! IPDBIN - PDB input file -! ITHEP - virtual-bond torsional angle parametrs -! IROTAM - side-chain geometry and local-interaction parameters -! ITORP - torsional parameters -! ITORDP - double torsional parameters -! IFOURIER - coefficients of the expansion of local-interaction energy -! IELEP - electrostatic-interaction parameters -! ISIDEP - side-chain interaction parameters. -! ISCPP - SCp interaction parameters. -! IBOND - virtual-bond constant parameters and moments of inertia. -! ISCCOR - parameters of the potential of SCCOR term -! ICBASE - data base with Cartesian coords of known structures. -! ISTAT - energies and other conf. characteristics from an MCM run. -! IENTIN - entropy from preceeding simulation(s) to be read in. -! SECPRED - SECONDARY STRUCTURE PREDICTION for dihedral constraint generation. -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module io_units diff --git a/source/unres/data/map_data.F90 b/source/unres/data/map_data.F90 new file mode 100644 index 0000000..b706d35 --- /dev/null +++ b/source/unres/data/map_data.F90 @@ -0,0 +1,10 @@ + module map_data +!----------------------------------------------------------------------------- +! commom.map +! common /mapp/ + integer :: nmap + integer,dimension(:),allocatable :: kang,res1,res2,nstep !(maxvar) + real(kind=8),dimension(:),allocatable :: ang_from,ang_to !(maxvar) +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module map_data diff --git a/source/unres/data/map_data.f90 b/source/unres/data/map_data.f90 deleted file mode 100644 index b706d35..0000000 --- a/source/unres/data/map_data.f90 +++ /dev/null @@ -1,10 +0,0 @@ - module map_data -!----------------------------------------------------------------------------- -! commom.map -! common /mapp/ - integer :: nmap - integer,dimension(:),allocatable :: kang,res1,res2,nstep !(maxvar) - real(kind=8),dimension(:),allocatable :: ang_from,ang_to !(maxvar) -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module map_data diff --git a/source/unres/data/minim_data.F90 b/source/unres/data/minim_data.F90 new file mode 100644 index 0000000..cfa788d --- /dev/null +++ b/source/unres/data/minim_data.F90 @@ -0,0 +1,13 @@ + module minim_data +!----------------------------------------------------------------------------- +! commom.minim +! common /minimm/ + real(kind=8) :: tolf,rtolf + integer :: maxfun,maxmin,minfun,minmin,& + print_min_ini,print_min_stat,print_min_res +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: minim_jlee,minimize,minim_dc, +! minim_mcmf,minimize_sc1 + real(kind=8),dimension(:),allocatable :: v !77+maxvar*(maxvar+17)/2 (maxvar=6*maxres) +!----------------------------------------------------------------------------- + end module minim_data diff --git a/source/unres/data/minim_data.f90 b/source/unres/data/minim_data.f90 deleted file mode 100644 index cfa788d..0000000 --- a/source/unres/data/minim_data.f90 +++ /dev/null @@ -1,13 +0,0 @@ - module minim_data -!----------------------------------------------------------------------------- -! commom.minim -! common /minimm/ - real(kind=8) :: tolf,rtolf - integer :: maxfun,maxmin,minfun,minmin,& - print_min_ini,print_min_stat,print_min_res -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: minim_jlee,minimize,minim_dc, -! minim_mcmf,minimize_sc1 - real(kind=8),dimension(:),allocatable :: v !77+maxvar*(maxvar+17)/2 (maxvar=6*maxres) -!----------------------------------------------------------------------------- - end module minim_data diff --git a/source/unres/data/names.F90 b/source/unres/data/names.F90 new file mode 100644 index 0000000..d5a23a2 --- /dev/null +++ b/source/unres/data/names.F90 @@ -0,0 +1,66 @@ + module names +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! Number of AA types (at present only natural AA's will be handled + integer,parameter :: ntyp=24,ntyp1=ntyp+1 +!----------------------------------------------------------------------------- +! common.names +! common /names/ +!el character(len=3),dimension(:),allocatable :: restyp !(-ntyp1:ntyp1) +!el character(len=1),dimension(:),allocatable :: onelet !(-ntyp1:ntyp1) +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! block data nazwy +!el allocate(restyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) + character(len=3),dimension(-ntyp1:ntyp1) :: restyp = & + (/'DD ','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS',& + 'DGL','DSG','DGN','DSN','DTH',& + 'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',& + 'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',& + 'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ',& + 'AIB','ABU','D '/) +!el allocate(onelet(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) + character(len=1),dimension(-ntyp1:ntyp1) :: onelet = & + (/'z','z','z','z','z','p','k','r','h','d','e','n','q','s',& + 't','g','a','y','w','v','l','i','f','m','c','x',& + 'C','M','F','I','L','V','W','Y','A','G','T',& + 'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/) +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! Number of energy components + integer,parameter :: n_ene=21 + integer :: n_ene2=2*n_ene +!----------------------------------------------------------------------------- +! common.names +!#ifndef WHAM_RUN +! common /namterm/ +! character(len=10),dimension(n_ene) :: ename = & +! (/"EVDW SC-SC","EVDW2 SC-p","EES p-p ","ECORR4 ","ECORR5 ",& +! "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",& +! "EBE bend ","ESC SCloc ","ETORS ","ETORSD ","EHPB ","EVDWPP ",& +! "ESTR ","EVDW2_14 ","UCONST "," ","ESCCOR "/) +! character(len=10),dimension(n_ene) :: wname = & +! (/"WSC ","WSCP ","WELEC ","WCORR ","WCORR5 ","WCORR6 ","WEL_LOC ",& +! "WTURN3 ","WTURN4 ","WTURN6 ","WANG ","WSCLOC ","WTOR ","WTORD ",& +! "WSTRAIN ","WVDWPP ","WBOND ","SCAL14 "," "," ","WSCCOR "/) +! integer :: nprint_ene = 20 +! integer,dimension(n_ene) :: print_order = & +! (/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,21,0/) +!#else + character(len=10),dimension(n_ene) :: ename = & + (/"EVDW SC-SC","EVDW2 SC-p","EES p-p ","ECORR4 ","ECORR5 ",& + "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",& + "EBE bend ","ESC SCloc ","ETORS ","ETORSD ","EHPB ","EVDWPP ",& + "EVDW2_14 ","ESTR ","ESCCOR ","EDIHC ","EVDW_T "/) + character(len=10),dimension(n_ene) :: wname = & + (/"WSC ","WSCP ","WELEC" ,"WCORR ","WCORR5 ","WCORR6 ","WEL_LOC ",& + "WTURN3 ","WTURN4 ","WTURN6 ","WANG ","WSCLOC ","WTOR ","WTORD ",& + "WHPB ","WVDWPP ","WSCP14 ","WBOND ","WSCCOR ","WDIHC ","WSC "/) + + integer :: nprint_ene = 21 + integer,dimension(n_ene) :: print_order = & + (/1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19,16,15,17,20,21/) +!#endif +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module names diff --git a/source/unres/data/names.f90 b/source/unres/data/names.f90 deleted file mode 100644 index d5a23a2..0000000 --- a/source/unres/data/names.f90 +++ /dev/null @@ -1,66 +0,0 @@ - module names -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! Number of AA types (at present only natural AA's will be handled - integer,parameter :: ntyp=24,ntyp1=ntyp+1 -!----------------------------------------------------------------------------- -! common.names -! common /names/ -!el character(len=3),dimension(:),allocatable :: restyp !(-ntyp1:ntyp1) -!el character(len=1),dimension(:),allocatable :: onelet !(-ntyp1:ntyp1) -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! block data nazwy -!el allocate(restyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) - character(len=3),dimension(-ntyp1:ntyp1) :: restyp = & - (/'DD ','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS',& - 'DGL','DSG','DGN','DSN','DTH',& - 'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',& - 'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',& - 'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ',& - 'AIB','ABU','D '/) -!el allocate(onelet(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) - character(len=1),dimension(-ntyp1:ntyp1) :: onelet = & - (/'z','z','z','z','z','p','k','r','h','d','e','n','q','s',& - 't','g','a','y','w','v','l','i','f','m','c','x',& - 'C','M','F','I','L','V','W','Y','A','G','T',& - 'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/) -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! Number of energy components - integer,parameter :: n_ene=21 - integer :: n_ene2=2*n_ene -!----------------------------------------------------------------------------- -! common.names -!#ifndef WHAM_RUN -! common /namterm/ -! character(len=10),dimension(n_ene) :: ename = & -! (/"EVDW SC-SC","EVDW2 SC-p","EES p-p ","ECORR4 ","ECORR5 ",& -! "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",& -! "EBE bend ","ESC SCloc ","ETORS ","ETORSD ","EHPB ","EVDWPP ",& -! "ESTR ","EVDW2_14 ","UCONST "," ","ESCCOR "/) -! character(len=10),dimension(n_ene) :: wname = & -! (/"WSC ","WSCP ","WELEC ","WCORR ","WCORR5 ","WCORR6 ","WEL_LOC ",& -! "WTURN3 ","WTURN4 ","WTURN6 ","WANG ","WSCLOC ","WTOR ","WTORD ",& -! "WSTRAIN ","WVDWPP ","WBOND ","SCAL14 "," "," ","WSCCOR "/) -! integer :: nprint_ene = 20 -! integer,dimension(n_ene) :: print_order = & -! (/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,21,0/) -!#else - character(len=10),dimension(n_ene) :: ename = & - (/"EVDW SC-SC","EVDW2 SC-p","EES p-p ","ECORR4 ","ECORR5 ",& - "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",& - "EBE bend ","ESC SCloc ","ETORS ","ETORSD ","EHPB ","EVDWPP ",& - "EVDW2_14 ","ESTR ","ESCCOR ","EDIHC ","EVDW_T "/) - character(len=10),dimension(n_ene) :: wname = & - (/"WSC ","WSCP ","WELEC" ,"WCORR ","WCORR5 ","WCORR6 ","WEL_LOC ",& - "WTURN3 ","WTURN4 ","WTURN6 ","WANG ","WSCLOC ","WTOR ","WTORD ",& - "WHPB ","WVDWPP ","WSCP14 ","WBOND ","WSCCOR ","WDIHC ","WSC "/) - - integer :: nprint_ene = 21 - integer,dimension(n_ene) :: print_order = & - (/1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19,16,15,17,20,21/) -!#endif -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module names diff --git a/source/unres/energy.F90 b/source/unres/energy.F90 new file mode 100644 index 0000000..fdf4576 --- /dev/null +++ b/source/unres/energy.F90 @@ -0,0 +1,16248 @@ + module energy +!----------------------------------------------------------------------------- + use io_units + use names + use math + use MPI_data + use energy_data + use control_data + use geometry_data + use geometry +! + implicit none +!----------------------------------------------------------------------------- +! Max. number of contacts per residue +! integer :: maxconts +!----------------------------------------------------------------------------- +! Max. number of derivatives of virtual-bond and side-chain vectors in theta +! or phi. +! integer :: maxdim +!----------------------------------------------------------------------------- +! Max. number of SC contacts +! integer :: maxcont +!----------------------------------------------------------------------------- +! Max. number of variables + integer :: maxvar +!----------------------------------------------------------------------------- +! Max number of torsional terms in SCCOR in control_data +! integer,parameter :: maxterm_sccor=6 +!----------------------------------------------------------------------------- +! Maximum number of SC local term fitting function coefficiants + integer,parameter :: maxsccoef=65 +!----------------------------------------------------------------------------- +! commom.calc common/calc/ +!----------------------------------------------------------------------------- +! commom.contacts +! common /contacts/ +! Change 12/1/95 - common block CONTACTS1 included. +! common /contacts1/ + integer,dimension(:),allocatable :: num_cont !(maxres) + integer,dimension(:,:),allocatable :: jcont !(maxconts,maxres) + real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres) + real(kind=8),dimension(:,:,:),allocatable :: gacont !(3,maxconts,maxres) +! +! 12/26/95 - H-bonding contacts +! common /contacts_hb/ + real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,& + gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont !(3,maxconts,maxres) + real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,& + ees0m,d_cont !(maxconts,maxres) + integer,dimension(:),allocatable :: num_cont_hb !(maxres) + integer,dimension(:,:),allocatable :: jcont_hb !(maxconts,maxres) +! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +! interactions +! 7/25/08 commented out; not needed when cumulants used +! Interactions of pseudo-dipoles generated by loc-el interactions. +! common /dipint/ + real(kind=8),dimension(:,:,:),allocatable :: dip,& + dipderg !(4,maxconts,maxres) + real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres) +! 10/30/99 Added other pre-computed vectors and matrices needed +! to calculate three - six-order el-loc correlation terms +! common /rotat/ + real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der !(2,2,maxres) + real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,& + obrot2_der !(2,maxres) +! +! This common block contains vectors and matrices dependent on a single +! amino-acid residue. +! common /precomp1/ + real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,& + Ctobr,Ctobrder,Dtobr2,Dtobr2der !(2,maxres) + real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,& + CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres) +! This common block contains vectors and matrices dependent on two +! consecutive amino-acid residues. +! common /precomp2/ + real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,& + CUgb2,CUgb2der !(2,maxres) + real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,& + EUgD,EUgDder,DtUg2EUg,Ug2DtEUg !(2,2,maxres) + real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,& + DtUg2EUgder !(2,2,2,maxres) +! common /rotat_old/ + real(kind=8),dimension(:),allocatable :: costab,sintab,& + costab2,sintab2 !(maxres) +! This common block contains dipole-interaction matrices and their +! Cartesian derivatives. +! common /dipmat/ + real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj !(2,2,maxconts,maxres) + real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der !(2,2,3,5,maxconts,maxres) +! common /diploc/ + real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,& + AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2 + real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,& + ADtEA1derg,AEAb2derg + real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,& + AECAderx,ADtEAderx,ADtEA1derx + real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx + real(kind=8),dimension(3,2) :: g_contij + real(kind=8) :: ekont +! 12/13/2008 (again Poland-Jaruzel war anniversary) +! RE: Parallelization of 4th and higher order loc-el correlations +! common /contdistrib/ + integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres) +! ncont_sent,ncont_recv są w multibody_ello i multibody_hb +!----------------------------------------------------------------------------- +! commom.deriv; +! common /derivat/ +! real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim) +! real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres) +! real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2) + real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,& + gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,& + gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,& + gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres) +! real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2) + real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,& + gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres) + real(kind=8),dimension(:),allocatable :: gel_loc_loc,& + gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,& + g_corr6_loc !(maxvar) + real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres) + real(kind=8),dimension(:),allocatable :: gsccor_loc !(maxres) +! real(kind=8),dimension(:,:,:),allocatable :: dtheta !(3,2,maxres) + real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres) +! real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres) +! integer :: nfl,icg +! common /deriv_loc/ + real(kind=8),dimension(3,5,2) :: derx,derx_turn +! common /deriv_scloc/ + real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,& + dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,& + dZZ_XYZtab !(3,maxres) +!----------------------------------------------------------------------------- +! common.maxgrad +! common /maxgrad/ + real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,& + gradb_max,ghpbc_max,& + gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,& + gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,& + gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,& + gsccorx_max,gsclocx_max +!----------------------------------------------------------------------------- +! common.MD +! common /back_constr/ + real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres) + real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres) +! common /qmeas/ + real(kind=8) :: Ucdfrag,Ucdpair + real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,& + dqwol,dxqwol !(3,0:MAXRES) +!----------------------------------------------------------------------------- +! common.sbridge +! common /dyn_ssbond/ + real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres) +!----------------------------------------------------------------------------- +! common.sccor +! Parameters of the SCCOR term +! common/sccor/ + real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,& + dcosomicron,domicron !(3,3,3,maxres2) +!----------------------------------------------------------------------------- +! common.vectors +! common /vectors/ + real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres) + real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres) +!----------------------------------------------------------------------------- +! common /przechowalnia/ + real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs) + real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! energy_p_new_barrier.F +!----------------------------------------------------------------------------- + subroutine etotal(energia) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use MD_data, only: totT +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' + real(kind=8),dimension(0:n_ene) :: energia +! include 'COMMON.LOCAL' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.CONTROL' +! include 'COMMON.TIME1' + real(kind=8) :: time00 +!el local variables + integer :: n_corr,n_corr1,ierror + real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb + real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc + real(kind=8) :: eello_turn3,eello_turn4,estr,ebe + real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 + +#ifdef MPI + real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw +! print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, +! & " nfgtasks",nfgtasks + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +! FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) +! print *,"Processor",myrank," BROADCAST iorder" +! FG master sets up the WEIGHTS_ array which will be broadcast to the +! FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor +! FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene,& + MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +! FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene,& + MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + endif + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +! call chainbuild_cart + endif +! print *,'Processor',myrank,' calling etotal ipot=',ipot +! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#else +! if (modecalc.eq.12.or.modecalc.eq.14) then +! call int_from_cart1(.false.) +! endif +#endif +#ifdef TIMING + time00=MPI_Wtime() +#endif +! +! Compute the side-chain and electrostatic interaction energy +! +! goto (101,102,103,104,105,106) ipot + select case(ipot) +! Lennard-Jones potential. +! 101 call elj(evdw) + case (1) + call elj(evdw) +!d print '(a)','Exit ELJcall el' +! goto 107 +! Lennard-Jones-Kihara potential (shifted). +! 102 call eljk(evdw) + case (2) + call eljk(evdw) +! goto 107 +! Berne-Pechukas potential (dilated LJ, angular dependence). +! 103 call ebp(evdw) + case (3) + call ebp(evdw) +! goto 107 +! Gay-Berne potential (shifted LJ, angular dependence). +! 104 call egb(evdw) + case (4) + call egb(evdw) +! goto 107 +! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). +! 105 call egbv(evdw) + case (5) + call egbv(evdw) +! goto 107 +! Soft-sphere potential +! 106 call e_softsphere(evdw) + case (6) + call e_softsphere(evdw) +! +! Calculate electrostatic (H-bonding) energy of the main chain. +! +! 107 continue + case default + write(iout,*)"Wrong ipot" +! return +! 50 continue + end select +! continue + +!mc +!mc Sep-06: egb takes care of dynamic ss bonds too +!mc +! if (dyn_ss) call dyn_set_nss +! print *,"Processor",myrank," computed USCSC" +#ifdef TIMING + time01=MPI_Wtime() +#endif + call vec_and_deriv +#ifdef TIMING + time_vec=time_vec+MPI_Wtime()-time01 +#endif +! print *,"Processor",myrank," left VEC_AND_DERIV" + if (ipot.lt.6) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. & + wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & + .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & + .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. & + wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & + .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & + .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +! write (iout,*) "ELEC calc" + else + ees=0.0d0 + evdw1=0.0d0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + endif + else +! write (iout,*) "Soft-spheer ELEC potential" + call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,& + eello_turn4) + endif +! print *,"Processor",myrank," computed UELEC" +! +! Calculate excluded-volume interaction energy between peptide groups +! and side chains. +! +!elwrite(iout,*) "in etotal calc exc;luded",ipot + + if (ipot.lt.6) then + if(wscp.gt.0d0) then + call escp(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else +! write (iout,*) "Soft-sphere SCP potential" + call escp_soft_sphere(evdw2,evdw2_14) + endif +!elwrite(iout,*) "in etotal before ebond",ipot + +! +! Calculate the bond-stretching energy +! + call ebond(estr) +!elwrite(iout,*) "in etotal afer ebond",ipot + +! +! Calculate the disulfide-bridge and other energy and the contributions +! from other distance constraints. +! print *,'Calling EHPB' + call edis(ehpb) +!elwrite(iout,*) "in etotal afer edis",ipot +! print *,'EHPB exitted succesfully.' +! +! Calculate the virtual-bond-angle energy. +! + if (wang.gt.0d0) then + call ebend(ebe) + else + ebe=0 + endif +! print *,"Processor",myrank," computed UB" +! +! Calculate the SC local energy. +! + call esc(escloc) +!elwrite(iout,*) "in etotal afer esc",ipot +! print *,"Processor",myrank," computed USC" +! +! Calculate the virtual-bond torsional energy. +! +!d print *,'nterm=',nterm + if (wtor.gt.0) then + call etor(etors,edihcnstr) + else + etors=0 + edihcnstr=0 + endif +! print *,"Processor",myrank," computed Utor" +! +! 6/23/01 Calculate double-torsional energy +! +!elwrite(iout,*) "in etotal",ipot + if (wtor_d.gt.0) then + call etor_d(etors_d) + else + etors_d=0 + endif +! print *,"Processor",myrank," computed Utord" +! +! 21/5/07 Calculate local sicdechain correlation energy +! + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +! print *,"Processor",myrank," computed Usccorr" +! +! 12/1/95 Multi-body terms +! + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 & + .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +!d write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, +!d &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 + else + ecorr=0.0d0 + ecorr5=0.0d0 + ecorr6=0.0d0 + eturn6=0.0d0 + endif +!elwrite(iout,*) "in etotal",ipot + if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +!d write (iout,*) "multibody_hb ecorr",ecorr + endif +!elwrite(iout,*) "afeter multibody hb" + +! print *,"Processor",myrank," computed Ucorr" +! +! If performing constraint dynamics, call the constraint energy +! after the equilibration time + if(usampl.and.totT.gt.eq_time) then +!elwrite(iout,*) "afeter multibody hb" + call EconstrQ +!elwrite(iout,*) "afeter multibody hb" + call Econstr_back +!elwrite(iout,*) "afeter multibody hb" + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +!elwrite(iout,*) "after Econstr" + +#ifdef TIMING + time_enecalc=time_enecalc+MPI_Wtime()-time00 +#endif +! print *,"Processor",myrank," computed Uconstr" +#ifdef TIMING + time00=MPI_Wtime() +#endif +! +! Sum the energies +! + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(19)=edihcnstr + energia(17)=estr + energia(20)=Uconst+Uconst_back + energia(21)=esccor +! Here are the energies showed per procesor if the are more processors +! per molecule then we sum it up in sum_energy subroutine +! print *," Processor",myrank," calls SUM_ENERGY" + call sum_energy(energia,.true.) + if (dyn_ss) call dyn_set_nss +! print *," Processor",myrank," left SUM_ENERGY" +#ifdef TIMING + time_sumene=time_sumene+MPI_Wtime()-time00 +#endif +!el call enerprint(energia) +!elwrite(iout,*)"finish etotal" + return + end subroutine etotal +!----------------------------------------------------------------------------- + subroutine sum_energy(energia,reduce) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' + real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1) +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.CONTROL' +! include 'COMMON.TIME1' + logical :: reduce + real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6 + real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc + real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot + integer :: i +#ifdef MPI + integer :: ierr + real(kind=8) :: time00 + if (nfgtasks.gt.1 .and. reduce) then + +#ifdef DEBUG + write (iout,*) "energies before REDUCE" + call enerprint(energia) + call flush(iout) +#endif + do i=0,n_ene + enebuff(i)=energia(i) + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_e=time_barrier_e+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(enebuff(0),energia(0),n_ene+1,& + MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) +#ifdef DEBUG + write (iout,*) "energies after REDUCE" + call enerprint(energia) + call flush(iout) +#endif + time_Reduce=time_Reduce+MPI_Wtime()-time00 + endif + if (fg_rank.eq.0) then +#endif + evdw=energia(1) +#ifdef SCP14 + evdw2=energia(2)+energia(18) + evdw2_14=energia(18) +#else + evdw2=energia(2) +#endif +#ifdef SPLITELE + ees=energia(3) + evdw1=energia(16) +#else + ees=energia(3) + evdw1=0.0d0 +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eturn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 & + +wang*ebe+wtor*etors+wscloc*escloc & + +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & + +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 & + +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & + +wbond*estr+Uconst+wsccor*esccor +#else + etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) & + +wang*ebe+wtor*etors+wscloc*escloc & + +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & + +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 & + +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & + +wbond*estr+Uconst+wsccor*esccor +#endif + energia(0)=etot +! detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPI + endif +#endif +! call enerprint(energia) + call flush(iout) + return + end subroutine sum_energy +!----------------------------------------------------------------------------- + subroutine rescale_weights(t_bath) +! implicit real*8 (a-h,o-z) +#ifdef MPI + include 'mpif.h' +#endif +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' + real(kind=8) :: kfac=2.4d0 + real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644 +!el local variables + real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6 + real(kind=8) :: T0=3.0d2 + integer :: ierror +! facT=temp0/t_bath +! facT=2*temp0/(t_bath+temp0) + if (rescale_mode.eq.0) then + facT(1)=1.0d0 + facT(2)=1.0d0 + facT(3)=1.0d0 + facT(4)=1.0d0 + facT(5)=1.0d0 + facT(6)=1.0d0 + else if (rescale_mode.eq.1) then + facT(1)=kfac/(kfac-1.0d0+t_bath/temp0) + facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) + facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) + facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) + facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) +#ifdef WHAM_RUN +!#if defined(WHAM_RUN) || defined(CLUSTER) +#if defined(FUNCTH) +! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) + facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 +#elif defined(FUNCT) + facT(6)=t_bath/T0 +#else + facT(6)=1.0d0 +#endif +#endif + else if (rescale_mode.eq.2) then + x=t_bath/temp0 + x2=x*x + x3=x2*x + x4=x3*x + x5=x4*x + facT(1)=licznik/dlog(dexp(x)+dexp(-x)) + facT(2)=licznik/dlog(dexp(x2)+dexp(-x2)) + facT(3)=licznik/dlog(dexp(x3)+dexp(-x3)) + facT(4)=licznik/dlog(dexp(x4)+dexp(-x4)) + facT(5)=licznik/dlog(dexp(x5)+dexp(-x5)) +#ifdef WHAM_RUN +!#if defined(WHAM_RUN) || defined(CLUSTER) +#if defined(FUNCTH) + facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 +#elif defined(FUNCT) + facT(6)=t_bath/T0 +#else + facT(6)=1.0d0 +#endif +#endif + else + write (iout,*) "Wrong RESCALE_MODE",rescale_mode + write (*,*) "Wrong RESCALE_MODE",rescale_mode +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) +#endif + stop 555 + endif + welec=weights(3)*fact(1) + wcorr=weights(4)*fact(3) + wcorr5=weights(5)*fact(4) + wcorr6=weights(6)*fact(5) + wel_loc=weights(7)*fact(2) + wturn3=weights(8)*fact(2) + wturn4=weights(9)*fact(3) + wturn6=weights(10)*fact(5) + wtor=weights(13)*fact(1) + wtor_d=weights(14)*fact(2) + wsccor=weights(21)*fact(1) + + return + end subroutine rescale_weights +!----------------------------------------------------------------------------- + subroutine enerprint(energia) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.MD' + real(kind=8) :: energia(0:n_ene) +!el local variables + real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc + real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc + real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor + + etot=energia(0) + evdw=energia(1) + evdw2=energia(2) +#ifdef SCP14 + evdw2=energia(2)+energia(18) +#else + evdw2=energia(2) +#endif + ees=energia(3) +#ifdef SPLITELE + evdw1=energia(16) +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) +#ifdef SPLITELE + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,& + estr,wbond,ebe,wang,& + escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,& + ecorr,wcorr,& + ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,& + eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,& + edihcnstr,ebr*nss,& + Uconst,etot + 10 format (/'Virtual-chain energies:'// & + 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & + 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & + 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ & + 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ & + 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & + 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & + 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & + 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & + 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & + 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & + ' (SS bridges & dist. cnstr.)'/ & + 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & + 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & + 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & + 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & + 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & + 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & + 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & + 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & + 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & + 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & + 'UCONST= ',1pE16.6,' (Constraint energy)'/ & + 'ETOT= ',1pE16.6,' (total)') +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,& + estr,wbond,ebe,wang,& + escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,& + ecorr,wcorr,& + ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,& + eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,& + ebr*nss,Uconst,etot + 10 format (/'Virtual-chain energies:'// & + 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & + 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & + 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ & + 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & + 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & + 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & + 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & + 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & + 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & + ' (SS bridges & dist. cnstr.)'/ & + 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & + 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & + 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & + 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & + 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & + 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & + 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & + 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & + 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & + 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & + 'UCONST=',1pE16.6,' (Constraint energy)'/ & + 'ETOT= ',1pE16.6,' (total)') +#endif + return + end subroutine enerprint +!----------------------------------------------------------------------------- + subroutine elj(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the LJ potential of interaction. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + real(kind=8),parameter :: accur=1.0d-10 +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.TORSION' +! include 'COMMON.SBRIDGE' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTACTS' + real(kind=8),dimension(3) :: gg + integer :: num_conti +!el local variables + integer :: i,itypi,iint,j,itypi1,itypj,k + real(kind=8) :: rij,rcut,fcont,fprimcont,rrij + real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj + real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij + +! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 +! allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2 +! allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4) +! allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) +! allocate(gacont(3,nres/4,iatsc_s:iatsc_e)) !(3,maxconts,maxres) + + do i=iatsc_s,iatsc_e + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +! Change 12/1/95 + num_conti=0 +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) +!d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +!d & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +! Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +! write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 +!d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +!d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +!d write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +!d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +!d & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +!d & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+evdwij +! +! Calculate the components of the gradient in DC and X +! + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo +!grad do k=i,j-1 +!grad do l=1,3 +!grad gvdwc(l,k)=gvdwc(l,k)+gg(l) +!grad enddo +!grad enddo +! +! 12/1/95, revised on 5/20/97 +! +! Calculate the contact function. The ith column of the array JCONT will +! contain the numbers of atoms that make contacts with the atom I (of numbers +! greater than I). The arrays FACONT and GACONT will contain the values of +! the contact function and its derivative. +! +! Uncomment next line, if the correlation interactions include EVDW explicitly. +! if (j.gt.i+1 .and. evdwij.le.0.0D0) then +! Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +! +! Check whether the SC's are not too far to make a contact. +! + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +! Add a new contact, if the SC's are close enough, but not too close (ri' +!grad do k=1,3 +!grad ggg(k)=-ggg(k) +! Uncomment following line for SC-p interactions +! gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +!grad enddo +!grad endif +!grad do k=1,3 +!grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +!grad enddo +!grad kstart=min0(i+1,j) +!grad kend=max0(i-1,j-1) +!d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +!d write (iout,*) ggg(1),ggg(2),ggg(3) +!grad do k=kstart,kend +!grad do l=1,3 +!grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +!grad enddo +!grad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + enddo + + enddo ! iint + enddo ! i + return + end subroutine escp_soft_sphere +!----------------------------------------------------------------------------- + subroutine escp(evdw2,evdw2_14) +! +! This subroutine calculates the excluded-volume interaction energy between +! peptide-group centers and side chains and its gradient in virtual-bond and +! side-chain vectors. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' + real(kind=8),dimension(3) :: ggg +!el local variables + integer :: i,iint,j,k,iteli,itypj + real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,& + e1,e2,evdwij + + evdw2=0.0D0 + evdw2_14=0.0d0 +!d print '(a)','Enter ESCP' +!d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle +! Uncomment following three lines for SC-p interactions +! xj=c(1,nres+j)-xi +! yj=c(2,nres+j)-yi +! zj=c(3,nres+j)-zi +! Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+e1+e2 + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij +! if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') & +! 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),& + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & + 'evdw2',i,j,evdwij +! +! Calculate contributions to the gradient in the virtual-bond and SC vectors. +! + fac=-(evdwij+e1)*rrij + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +!grad if (j.lt.i) then +!d write (iout,*) 'ji' +!grad do k=1,3 +!grad ggg(k)=-ggg(k) +! Uncomment following line for SC-p interactions +!cgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +!grad enddo +!grad endif +!grad do k=1,3 +!grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +!grad enddo +!grad kstart=min0(i+1,j) +!grad kend=max0(i-1,j-1) +!d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +!d write (iout,*) ggg(1),ggg(2),ggg(3) +!grad do k=kstart,kend +!grad do l=1,3 +!grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +!grad enddo +!grad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + enddo + + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +!****************************************************************************** +! +! N O T E !!! +! +! To save time the factor EXPON has been extracted from ALL components +! of GVDWC and GRADX. Remember to multiply them by this factor before further +! use! +! +!****************************************************************************** + return + end subroutine escp +!----------------------------------------------------------------------------- + subroutine edis(ehpb) +! +! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' + real(kind=8),dimension(3) :: ggg +!el local variables + integer :: i,j,ii,jj,iii,jjj,k + real(kind=8) :: fac,eij,rdis,ehpb,dd,waga + + ehpb=0.0D0 +!d write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +!d write(iout,*)'link_start=',link_start,' link_end=',link_end + if (link_end.eq.0) return + do i=link_start,link_end +! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +! CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +! iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif +! write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +! & dhpb(i),dhpb1(i),forcon(i) +! 24/11/03 AL: SS bridges handled separately because of introducing a specific +! distance and angle dependent SS bond potential. +!mc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +! 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. & + iabs(itype(jjj)).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij +!d write (iout,*) "eij",eij + endif + else +! Calculate the distance between the two points and its difference from the +! target distance. + dd=dist(ii,jj) + rdis=dd-dhpb(i) +! Get the force constant corresponding to this distance. + waga=forcon(i) +! Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +! +! Evaluate gradient. +! + fac=waga*rdis/dd +!d print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +!d & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +!d print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +! If this is a SC-SC distance, we need to calculate the contributions to the +! Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif +!grad do j=iii,jjj-1 +!grad do k=1,3 +!grad ghpbc(k,j)=ghpbc(k,j)+ggg(k) +!grad enddo +!grad enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + ehpb=0.5D0*ehpb + return + end subroutine edis +!----------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +! +! Calculate the distance and angle dependent SS-bond potential energy +! using a free-energy function derived based on RHF/6-31G** ab initio +! calculations of diethyl disulfide. +! +! A. Liwo and U. Kozlowska, 11/24/03 +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' + real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg +!el local variables + integer :: i,j,itypi,itypj,k + real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,& + xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,& + deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,& + cosphi,ggk + + itypi=iabs(itype(i)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(nres+i) + itypj=iabs(itype(j)) +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(nres+j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) & + +akct*deltad*deltat12 & + +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr +! write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +! & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +! & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + ghpbx(k,i)=ghpbx(k,i)-ggk & + +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & + +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+ggk & + +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + ghpbc(k,i)=ghpbc(k,i)-ggk + ghpbc(k,j)=ghpbc(k,j)+ggk + enddo +! +! Calculate the components of the gradient in DC and X +! +!grad do k=i,j-1 +!grad do l=1,3 +!grad ghpbc(l,k)=ghpbc(l,k)+gg(l) +!grad enddo +!grad enddo + return + end subroutine ssbond_ene +!----------------------------------------------------------------------------- + subroutine ebond(estr) +! +! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.FFIELD' +! include 'COMMON.CONTROL' +! include 'COMMON.SETUP' + real(kind=8),dimension(3) :: u,ud +!el local variables + integer :: i,j,iti,nbi,k + real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,& + uprod1,uprod2 + + estr=0.0d0 + estr1=0.0d0 +! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) +! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) + + do i=ibondp_start,ibondp_end + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) + do j=1,3 + gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) & + *dc(j,i-1)/vbld(i) + enddo + if (energy_dec) write(iout,*) & + "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) + else + diff = vbld(i)-vbldp0 + if (energy_dec) write (iout,'(a7,i5,4f7.3)') & + "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +! write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) + endif + enddo + estr=0.5d0*AKP*estr+estr1 +! +! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +! + do i=ibond_start,ibond_end + iti=iabs(itype(i)) + if (iti.ne.10 .and. iti.ne.ntyp1) then + nbi=nbondterm(iti) + if (nbi.eq.1) then + diff=vbld(i+nres)-vbldsc0(1,iti) + if (energy_dec) write (iout,*) & + "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,& + AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end subroutine ebond +#ifdef CRYST_THETA +!----------------------------------------------------------------------------- + subroutine ebend(etheta) +! +! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +! angles gamma and its derivatives in consecutive thetas and gammas. +! + use comm_calcthet +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.FFIELD' +! include 'COMMON.CONTROL' +!el real(kind=8) :: term1,term2,termm,diffak,ratak,& +!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& +!el delthe0,sig0inv,sigtc,sigsqtc,delthec +!el integer :: it +!el common /calcthet/ term1,term2,termm,diffak,ratak,& +!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& +!el delthe0,sig0inv,sigtc,sigsqtc,delthec,it +!el local variables + integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,& + ichir21,ichir22 + real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,& + athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,& + f1,fprim1,E_tc1,ethetai,E_theta,E_tc + real(kind=8),dimension(2) :: y,z + + delta=0.02d0*pi +! time11=dexp(-2*time) +! time12=1.0d0 + etheta=0.0D0 +! write (*,'(a,i2)') 'EBEND ICG=',icg + do i=ithet_start,ithet_end + if (itype(i-1).eq.ntyp1) cycle +! Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + ichir1=isign(1,itype(i-2)) + ichir2=isign(1,itype(i)) + if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) + if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) + if (itype(i-1).eq.10) then + itype1=isign(10,itype(i-2)) + ichir11=isign(1,itype(i-2)) + ichir12=isign(1,itype(i-2)) + itype2=isign(10,itype(i)) + ichir21=isign(1,itype(i)) + ichir22=isign(1,itype(i)) + endif + + if (i.gt.3 .and. itype(i-2).ne.ntyp1) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres .and. itype(i).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) + z(1)=dcos(phii1) +#endif + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +! Calculate the "mean" value of theta from the part of the distribution +! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +! In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it,ichir1,ichir2) + bthetk=bthet(k,it,ichir1,ichir2) + if (it.eq.10) then + athetk=athet(k,itype1,ichir11,ichir12) + bthetk=bthet(k,itype2,ichir21,ichir22) + endif + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) + enddo + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +! Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) & + +athet(2,it,ichir1,ichir2)*y(1))*ss + dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) & + +bthet(2,it,ichir1,ichir2)*z(1))*ss + if (it.eq.10) then + dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) & + +athet(2,itype1,ichir11,ichir12)*y(1))*ss + dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) & + +bthet(2,itype2,ichir21,ichir22)*z(1))*ss + endif + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,& + E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,& + E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,& + E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,& + E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,& + E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,& + E_theta,E_tc) + endif + etheta=etheta+ethetai + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & + 'ebend',i,ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 + gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) + enddo +! Ufff.... We've done all this!!! + return + end subroutine ebend +!----------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc) + + use comm_calcthet +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.IOUNITS' +!el real(kind=8) :: term1,term2,termm,diffak,ratak,& +!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& +!el delthe0,sig0inv,sigtc,sigsqtc,delthec + integer :: i,j,k + real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc +!el integer :: it +!el common /calcthet/ term1,term2,termm,diffak,ratak,& +!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& +!el delthe0,sig0inv,sigtc,sigsqtc,delthec,it +!el local variables + real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,& + esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd + +! Calculate the contributions to both Gaussian lobes. +! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +! The "polynomial part" of the "standard deviation" of this part of +! the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +! Derivative of the "interior part" of the "standard deviation of the" +! gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +! Set the parameters of both Gaussian lobes of the distribution. +! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +! print *,i,sig,sigtc,sigsqtc +! Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +! Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +! NaNs in taking the logarithm. We extract the largest exponent which is added +! to the energy (this being the log of the distribution) at the end of energy +! term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +! The ratio between the gamma-independent and gamma-dependent lobes of +! the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +! Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +! Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +! Contribution of the bending energy from this theta is just the -log of +! the sum of the contributions from the two lobes and the pre-exponential +! factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +! NOW the derivatives!!! +! 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 & + +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre & + -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ & + aktc*term2)/termexp) + return + end subroutine theteng +#else +!----------------------------------------------------------------------------- + subroutine ebend(etheta) +! +! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +! angles gamma and its derivatives in consecutive thetas and gammas. +! ab initio-derived potentials from +! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.FFIELD' +! include 'COMMON.CONTROL' + real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm + real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle + real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble + logical :: lprn=.false., lprn1=.false. +!el local variables + integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m + real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai + real(kind=8) :: aux,etheta,ccl,ssl,scl,csl + + etheta=0.0D0 + do i=ithet_start,ithet_end + if (itype(i-1).eq.ntyp1) cycle + if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle + if (iabs(itype(i+1)).eq.20) iblock=2 + if (iabs(itype(i+1)).ne.20) iblock=1 + dethetai=0.0d0 + dephii=0.0d0 + dephii1=0.0d0 + theti2=0.5d0*theta(i) + ityp2=ithetyp((itype(i-1))) + do k=1,nntheterm + coskt(k)=dcos(k*theti2) + sinkt(k)=dsin(k*theti2) + enddo + if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + ityp1=ithetyp((itype(i-2))) +! propagation of chirality for glycine type + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 + ityp1=ithetyp(itype(i-2)) + do k=1,nsingle + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) +#else + phii1=phi(i+1) +#endif + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=dcos(k*phii1) + sinph2(k)=dsin(k*phii1) + enddo + else + phii1=0.0d0 + ityp3=ithetyp(itype(i)) + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif + ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) + do k=1,ndouble + do l=1,k-1 + ccl=cosph1(l)*cosph2(k-l) + ssl=sinph1(l)*sinph2(k-l) + scl=sinph1(l)*cosph2(k-l) + csl=cosph1(l)*sinph2(k-l) + cosph1ph2(l,k)=ccl-ssl + cosph1ph2(k,l)=ccl+ssl + sinph1ph2(l,k)=scl+csl + sinph1ph2(k,l)=scl-csl + enddo + enddo + if (lprn) then + write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,& + " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 + write (iout,*) "coskt and sinkt" + do k=1,nntheterm + write (iout,*) k,coskt(k),sinkt(k) + enddo + endif + do k=1,ntheterm + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & + *coskt(k) + if (lprn) & + write (iout,*) "k",k,& + "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),& + " ethetai",ethetai + enddo + if (lprn) then + write (iout,*) "cosph and sinph" + do k=1,nsingle + write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + write (iout,*) "cosph1ph2 and sinph2ph2" + do k=2,ndouble + do l=1,k-1 + write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),& + sinph1ph2(l,k),sinph1ph2(k,l) + enddo + enddo + write(iout,*) "ethetai",ethetai + endif + do m=1,ntheterm2 + do k=1,nsingle + aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) & + +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) & + +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) & + +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*aux*coskt(m) + dephii=dephii+k*sinkt(m)* & + (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- & + bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) + dephii1=dephii1+k*sinkt(m)* & + (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- & + ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) + if (lprn) & + write (iout,*) "m",m," k",k," bbthet", & + bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", & + ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", & + ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", & + eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai + enddo + enddo + if (lprn) & + write(iout,*) "ethetai",ethetai + do m=1,ntheterm3 + do k=2,ndouble + do l=1,k-1 + aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & + ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ & + ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & + ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*coskt(m)*aux + dephii=dephii+l*sinkt(m)* & + (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- & + ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & + ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & + ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) + dephii1=dephii1+(k-l)*sinkt(m)* & + (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & + ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & + ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- & + ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) + if (lprn) then + write (iout,*) "m",m," k",k," l",l," ffthet",& + ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),& + ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",& + ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),& + ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),& + " ethetai",ethetai + write (iout,*) cosph1ph2(l,k)*sinkt(m),& + cosph1ph2(k,l)*sinkt(m),& + sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) + endif + enddo + enddo + enddo +10 continue +! lprn1=.true. + if (lprn1) & + write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') & + i,theta(i)*rad2deg,phii*rad2deg,& + phii1*rad2deg,ethetai +! lprn1=.false. + etheta=etheta+ethetai + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & + 'ebend',i,ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 + gloc(nphi+i-2,icg)=wang*dethetai + enddo + return + end subroutine ebend +#endif +#ifdef CRYST_SC +!----------------------------------------------------------------------------- + subroutine esc(escloc) +! Calculate the local energy of a side chain and its derivatives in the +! corresponding virtual-bond valence angles THETA and the spherical angles +! ALPHA and OMEGA. +! + use comm_sccalc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.FFIELD' +! include 'COMMON.CONTROL' + real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,& + ddersc0,ddummy,xtemp,temp +!el real(kind=8) :: time11,time12,time112,theti + real(kind=8) :: escloc,delta +!el integer :: it,nlobit +!el common /sccalc/ time11,time12,time112,theti,it,nlobit +!el local variables + integer :: i,k + real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,& + dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd + delta=0.02d0*pi + escloc=0.0D0 +! write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.ntyp1) cycle + if (it.eq.10) goto 1 + nlobit=nlob(iabs(it)) +! print *,'i=',i,' it=',it,' nlobit=',nlobit +! write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),& + escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),& + ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),& + ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,& + dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),& + dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +! write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +! & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +! escloci=esclocbi +! write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),& + escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),& + ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),& + ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,& + dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),& + dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +! write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +! & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +! write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & + 'escloc',i,escloci +! write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & + wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end subroutine esc +!----------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + + use comm_sccalc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.IOUNITS' +!el common /sccalc/ time11,time12,time112,theti,it,nlobit + real(kind=8),dimension(3) :: x,z,dersc,ddersc + real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1) + real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1) + real(kind=8) :: escloci + logical :: mixed +!el local variables + integer :: j,iii,l,k !el,it,nlobit + real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,& +!el time11,time12,time112 +! write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +! Because of periodicity of the dependence of the SC energy in omega we have +! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +! To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +! As in the case of ebend, we want to avoid underflows in exponentiation and +! subsequent NaNs and INFs in energy calculation. +! Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +!d print *,'it=',it,' emin=',emin + +! Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit +#ifdef OSF + adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin + if(adexp.ne.adexp) adexp=1.0 + expfac=dexp(adexp) +#else + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) +#endif +!d print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) & + +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end subroutine enesc +!----------------------------------------------------------------------------- + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + + use comm_sccalc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.IOUNITS' +!el common /sccalc/ time11,time12,time112,theti,it,nlobit + real(kind=8),dimension(3) :: x,z,dersc + real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob) + real(kind=8),dimension(nlobit) :: contr !(maxlob) + real(kind=8) :: escloci,dersc12,emin + logical :: mixed +!el local varables + integer :: j,k,l !el,it,nlobit + real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +! As in the case of ebend, we want to avoid underflows in exponentiation and +! subsequent NaNs and INFs in energy calculation. +! Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +! Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) & + +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end subroutine enesc_bound +#else +!----------------------------------------------------------------------------- + subroutine esc(escloc) +! Calculate the local energy of a side chain and its derivatives in the +! corresponding virtual-bond valence angles THETA and the spherical angles +! ALPHA and OMEGA derived from AM1 all-atom calculations. +! added by Urszula Kozlowska. 07/11/2007 +! + use comm_sccalc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.SCROT' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.FFIELD' +! include 'COMMON.CONTROL' +! include 'COMMON.VECTORS' + real(kind=8),dimension(3) :: x_prime,y_prime,z_prime + real(kind=8),dimension(65) :: x + real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,& + sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt + real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t + real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,& + dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1 +!el local variables + integer :: i,j,k !el,it,nlobit + real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta +!el real(kind=8) :: time11,time12,time112,theti +!el common /sccalc/ time11,time12,time112,theti,it,nlobit + real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,& + pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,& + sumene1x,sumene2x,sumene3x,sumene4x,& + sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,& + cosfac2xx,sinfac2yy +#ifdef DEBUG + real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,& + de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,& + de_dt_num +#endif +! if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres) + + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + if (itype(i).eq.ntyp1) cycle + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=iabs(itype(i)) + if (it.eq.10) goto 1 +! +! Compute the axes of tghe local cartesian coordinates system; store in +! x_prime, y_prime and z_prime +! + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +! write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +! & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) + enddo +! write (2,*) "i",i +! write (2,*) "x_prime",(x_prime(j),j=1,3) +! write (2,*) "y_prime",(y_prime(j),j=1,3) +! write (2,*) "z_prime",(z_prime(j),j=1,3) +! write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +! & " xy",scalar(x_prime(1),y_prime(1)), +! & " xz",scalar(x_prime(1),z_prime(1)), +! & " yy",scalar(y_prime(1),y_prime(1)), +! & " yz",scalar(y_prime(1),z_prime(1)), +! & " zz",scalar(z_prime(1),z_prime(1)) +! +! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +! to local coordinate system. Store in xx, yy, zz. +! + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +! +! Compute the energy of the ith side cbain +! +! write (2,*) "xx",xx," yy",yy," zz",zz + it=iabs(itype(i)) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +!c diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2)) + write(2,'(3f8.1,3f9.3,1x,3f9.3)') & + alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,& + xx1,yy1,zz1 +!," --- ", xx_w,yy_w,zz_w +! end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 & + + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy & + + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 & + + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy & + + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 & + +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy & + +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 & + +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx & + +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy & + +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 & + +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy & + +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 & + +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx & + +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy & + +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & + *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & + *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) & + + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +! write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +! & sumene4, +! & dscp1,dscp2,sumene +! sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +! write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) +! & ,zz,xx,yy +!#define DEBUG +#ifdef DEBUG +! +! This section to check the numerical derivatives of the energy of ith side +! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +! #define DEBUG in the code to turn it on. +! + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +! End of diagnostics section. +#endif +! +! Compute the gradient of esc +! +! zz=zz*dsign(1.0,dfloat(itype(i))) + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) & + *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) & + *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 & + +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) & + +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 & + +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) & + +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) & + +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) & + +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i) +#endif +! + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 & + +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) & + +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz & + +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz & + +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) & + +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) & + +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i) +#endif +! + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy & + +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx & + +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) & + +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) & + +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 & + +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy & + +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) & + + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i) +#endif +! + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) & + -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) & + +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i) +#endif +! +! + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* & + vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* & + vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +! write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +! & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +! write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +! & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) & + *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) & + *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + enddo + + dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) + dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) + dZZ_XYZ(k)=vbld_inv(i+nres)* & + (z_prime(k)-zz*dC_norm(k,i+nres)) +! + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +! write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +! & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +! write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +! & dyy_ci(k)," dzz_ci",dzz_ci(k) +! write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +! & dt_dci(k) +! write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +! & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) & + +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) & + +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) & + +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +! write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +! & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +! to check gradient call subroutine check_grad + + 1 continue + enddo + return + end subroutine esc +!----------------------------------------------------------------------------- + real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2) +! implicit none + real(kind=8),dimension(65) :: x + real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,& + sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 + + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 & + + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy & + + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 & + + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy & + + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 & + +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy & + +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 & + +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx & + +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy & + +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 & + +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy & + +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 & + +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx & + +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy & + +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & + *(xx*cost2+yy*sint2)) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & + *(xx*cost2-yy*sint2)) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) & + + (sumene4*cost2 +sumene2)*(s2+s2_6) + enesc=sumene + return + end function enesc +#endif +!----------------------------------------------------------------------------- + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +! +! This procedure calculates two-body contact function g(rij) and its derivative: +! +! eps0ij ! x < -1 +! g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +! 0 ! x > 1 +! +! where x=(rij-r0ij)/delta +! +! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +! +! implicit none + real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont + real(kind=8) :: x,x2,x4,delta +! delta=0.02D0*r0ij +! delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end subroutine gcont +!----------------------------------------------------------------------------- + subroutine splinthet(theti,delta,ss,ssder) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8) :: theti,delta,ss,ssder + real(kind=8) :: thetup,thetlow + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end subroutine splinthet +!----------------------------------------------------------------------------- + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) +! implicit none + real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim + real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end subroutine spline1 +!----------------------------------------------------------------------------- + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) +! implicit none + real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx + real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end subroutine spline2 +!----------------------------------------------------------------------------- +#ifdef CRYST_TOR +!----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' + real(kind=8) :: etors,edihcnstr + logical :: lprn +!el local variables + integer :: i,j, + real(kind=8) :: phii,fac,etors_ii + +! Set lprn=.true. for debugging + lprn=.false. +! lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 & + .or. itype(i).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +! Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ & + v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ & + v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & + 'etor',i,etors_ii + if (lprn) & + write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & + restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,& + (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +! write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end subroutine etor +!----------------------------------------------------------------------------- + subroutine etor_d(etors_d) + real(kind=8) :: etors_d + etors_d=0.0d0 + return + end subroutine etor_d +#else +!----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.TORCNSTR' +! include 'COMMON.CONTROL' + real(kind=8) :: etors,edihcnstr + logical :: lprn +!el local variables + integer :: i,j,iblock,itori,itori1 + real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,& + vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom +! Set lprn=.true. for debugging + lprn=.false. +! lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & + .or. itype(i-3).eq.ntyp1 & + .or. itype(i).eq.ntyp1) cycle + etors_ii=0.0D0 + if (iabs(itype(i)).eq.20) then + iblock=2 + else + iblock=1 + endif + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +! Regular cosine and sine terms + do j=1,nterm(itori,itori1,iblock) + v1ij=v1(j,itori,itori1,iblock) + v2ij=v2(j,itori,itori1,iblock) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + if (energy_dec) etors_ii=etors_ii+ & + v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +! Lorentz terms +! v1 +! E = SUM ----------------------------------- - v1 +! [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +! + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1,iblock) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + if (energy_dec) etors_ii=etors_ii+ & + vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +! Subtract the constant term + etors=etors-v0(itori,itori1,iblock) + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & + 'etor',i,etors_ii-v0(itori,itori1,iblock) + if (lprn) & + write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & + restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,& + (v1(j,itori,itori1,iblock),j=1,6),& + (v2(j,itori,itori1,iblock),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +! write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +! do i=1,ndih_constr + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else + difi=0.0 + endif +!d write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, +!d & rad2deg*phi0(i), rad2deg*drange(i), +!d & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +!d write (iout,*) 'edihcnstr',edihcnstr + return + end subroutine etor +!----------------------------------------------------------------------------- + subroutine etor_d(etors_d) +! 6/23/01 Compute double torsional energy +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.TORCNSTR' + real(kind=8) :: etors_d,etors_d_ii + logical :: lprn +!el local variables + integer :: i,j,k,l,itori,itori1,itori2,iblock + real(kind=8) :: phii,phii1,gloci1,gloci2,& + v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,& + sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,& + cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2 +! Set lprn=.true. for debugging + lprn=.false. +! lprn=.true. + etors_d=0.0D0 +! write(iout,*) "a tu??" + do i=iphid_start,iphid_end + etors_d_ii=0.0D0 + if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & + .or. itype(i-3).eq.ntyp1 & + .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 + iblock=1 + if (iabs(itype(i+1)).eq.20) iblock=2 + +! Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2,iblock) + v1cij=v1c(1,j,itori,itori1,itori2,iblock) + v1sij=v1s(1,j,itori,itori1,itori2,iblock) + v2cij=v1c(2,j,itori,itori1,itori2,iblock) + v2sij=v1s(2,j,itori,itori1,itori2,iblock) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ & + v2cij*cosphi2+v2sij*sinphi2 + if (energy_dec) etors_d_ii=etors_d_ii+ & + v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2,iblock) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2,iblock) + v2cdij = v2c(l,k,itori,itori1,itori2,iblock) + v1sdij = v2s(k,l,itori,itori1,itori2,iblock) + v2sdij = v2s(l,k,itori,itori1,itori2,iblock) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ & + v1sdij*sinphi1p2+v2sdij*sinphi1m2 + if (energy_dec) etors_d_ii=etors_d_ii+ & + v1cdij*cosphi1p2+v2cdij*cosphi1m2+ & + v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 & + -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 & + -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & + 'etor_d',i,etors_d_ii + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 + enddo + return + end subroutine etor_d +#endif +!----------------------------------------------------------------------------- + subroutine eback_sc_corr(esccor) +! 7/21/2007 Correlations between the backbone-local and side-chain-local +! conformational states; temporarily implemented as differences +! between UNRES torsional potentials (dependent on three types of +! residues) and the torsional potentials dependent on all 20 types +! of residues computed from AM1 energy surfaces of terminally-blocked +! amino-acid residues. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.SCCOR' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.CONTROL' + real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,& + cosphi,sinphi + logical :: lprn + integer :: i,interty,j,isccori,isccori1,intertyp +! Set lprn=.true. for debugging + lprn=.false. +! lprn=.true. +! write (iout,*) "EBACK_SC_COR",itau_start,itau_end + esccor=0.0D0 + do i=itau_start,itau_end + if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle + esccor_ii=0.0D0 + isccori=isccortyp(itype(i-2)) + isccori1=isccortyp(itype(i-1)) + +! write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) + phii=phi(i) + do intertyp=1,3 !intertyp + esccor_ii=0.0D0 +!c Added 09 May 2012 (Adasko) +!c Intertyp means interaction type of backbone mainchain correlation: +! 1 = SC...Ca...Ca...Ca +! 2 = Ca...Ca...Ca...SC +! 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. & + (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. & + (itype(i-1).eq.ntyp1))) & + .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) & + .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) & + .or.(itype(i).eq.ntyp1))) & + .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. & + (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. & + (itype(i-3).eq.ntyp1)))) cycle + if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle + if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) & + cycle + do j=1,nterm_sccor(isccori,isccori1) + v1ij=v1sccor(j,intertyp,isccori,isccori1) + v2ij=v2sccor(j,intertyp,isccori,isccori1) + cosphi=dcos(j*tauangle(intertyp,i)) + sinphi=dsin(j*tauangle(intertyp,i)) + if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') & + 'esccor',i,intertyp,esccor_ii +! write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp + gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci + if (lprn) & + write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & + restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,& + (v1sccor(j,intertyp,isccori,isccori1),j=1,6),& + (v2sccor(j,intertyp,isccori,isccori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + enddo !intertyp + enddo + + return + end subroutine eback_sc_corr +!----------------------------------------------------------------------------- + subroutine multibody(ecorr) +! This subroutine calculates multi-body contributions to energy following +! the idea of Skolnick et al. If side chains I and J make a contact and +! at the same time side chains I+1 and J+1 make a contact, an extra +! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' + real(kind=8),dimension(3) :: gx,gx1 + logical :: lprn + real(kind=8) :: ecorr + integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk +! Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') & + i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + +! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) +! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +!d write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +!d & ' ishift=',ishift +! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +! The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end subroutine multibody +!----------------------------------------------------------------------------- + real(kind=8) function esccorr(i,j,k,l,jj,kk) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' + real(kind=8),dimension(3) :: gx,gx1 + logical :: lprn + integer :: i,j,k,l,jj,kk,m,ll + real(kind=8) :: eij,ekl + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +!d write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +! Calculate the multi-body contribution to energy. +! Calculate multi-body contributions to the gradient. +!d write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +!d & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end function esccorr +!----------------------------------------------------------------------------- + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +! This subroutine calculates multi-body contributions to hydrogen-bonding +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" +! integer :: maxconts !max_cont=maxconts =nres/4 + integer,parameter :: max_dim=26 + integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) +!el real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) +!el common /przechowalnia/ zapas + integer :: status(MPI_STATUS_SIZE) + integer,dimension((nres/4)*2) :: req !maxconts*2 + integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr +#endif +! include 'COMMON.SETUP' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.CONTROL' +! include 'COMMON.LOCAL' + real(kind=8),dimension(3) :: gx,gx1 + real(kind=8) :: time00,ecorr,ecorr5,ecorr6 + logical :: lprn,ldone +!el local variables + integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,& + jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc + +! Set lprn=.true. for debugging + lprn=.false. +#ifdef MPI +! maxconts=nres/4 + if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks)) + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') & + i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& + j=1,num_cont_hb(i)) + enddo + endif + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +! write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +! & ntask_cont_to +! Make the list of contacts to send to send to other procesors +! write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end +! call flush(iout) + do i=iturn3_start,iturn3_end +! write (iout,*) "make contact list turn3",i," num_cont", +! & num_cont_hb(i) + call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +! write (iout,*) "make contact list turn4",i," num_cont", +! & num_cont_hb(i) + call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +! write (iout,*) "make contact list longrange",i,ii," num_cont", +! & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +! write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.gt.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,i) + zapas(4,nn,iproc)=ees0p(j,i) + zapas(5,nn,iproc)=ees0m(j,i) + zapas(6,nn,iproc)=gacont_hbr(1,j,i) + zapas(7,nn,iproc)=gacont_hbr(2,j,i) + zapas(8,nn,iproc)=gacont_hbr(3,j,i) + zapas(9,nn,iproc)=gacontm_hb1(1,j,i) + zapas(10,nn,iproc)=gacontm_hb1(2,j,i) + zapas(11,nn,iproc)=gacontm_hb1(3,j,i) + zapas(12,nn,iproc)=gacontp_hb1(1,j,i) + zapas(13,nn,iproc)=gacontp_hb1(2,j,i) + zapas(14,nn,iproc)=gacontp_hb1(3,j,i) + zapas(15,nn,iproc)=gacontm_hb2(1,j,i) + zapas(16,nn,iproc)=gacontm_hb2(2,j,i) + zapas(17,nn,iproc)=gacontm_hb2(3,j,i) + zapas(18,nn,iproc)=gacontp_hb2(1,j,i) + zapas(19,nn,iproc)=gacontp_hb2(2,j,i) + zapas(20,nn,iproc)=gacontp_hb2(3,j,i) + zapas(21,nn,iproc)=gacontm_hb3(1,j,i) + zapas(22,nn,iproc)=gacontm_hb3(2,j,i) + zapas(23,nn,iproc)=gacontm_hb3(3,j,i) + zapas(24,nn,iproc)=gacontp_hb3(1,j,i) + zapas(25,nn,iproc)=gacontp_hb3(2,j,i) + zapas(26,nn,iproc)=gacontp_hb3(3,j,i) + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) & + "Numbers of contacts to be sent to other processors",& + (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc,& + " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +! Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,& + FG_COMM,req(ireq),IERR) + enddo +! write (iout,*) "IRECV ended" +! call flush(iout) +! Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,& + FG_COMM,req(ireq),IERR) + enddo +! write (iout,*) "ISEND ended" +! write (iout,*) "number of requests (nn)",ireq + call flush(iout) + if (ireq.gt.0) & + call MPI_Waitall(ireq,req,status_array,ierr) +! write (iout,*) +! & "Numbers of contacts to be received from other processors", +! & (ncont_recv(i),i=1,ntask_cont_from) +! call flush(iout) +! Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +! write (iout,*) "Receiving",nn," contacts from processor",iproc, +! & " of CONT_TO_COMM group" + call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,& + MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +! write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +! Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +! write (iout,*) nn," contacts to processor",iproc, +! & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,& + iproc,CorrelType1,FG_COMM,req(ireq),IERR) +! write (iout,*) "ireq,req",ireq,req(ireq) +! do i=1,nn +! write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +! enddo + endif + enddo +! write (iout,*) "number of requests (contacts)",ireq +! write (iout,*) "req",(req(i),i=1,4) +! call flush(iout) + if (ireq.gt.0) & + call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc,& + " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +! Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +! write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +! call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + facont_hb(nnn,ii)=zapas_recv(3,i,iii) + ees0p(nnn,ii)=zapas_recv(4,i,iii) + ees0m(nnn,ii)=zapas_recv(5,i,iii) + gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) + gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) + gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) + gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) + gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) + gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) + gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) + gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) + gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) + gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) + gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) + gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) + gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) + gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) + gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) + gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) + gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) + gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) + gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) + gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) + gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) + enddo + enddo + call flush(iout) + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,f5.2))') & + i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& + j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,f5.2))') & + i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& + j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + +! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) +! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) +! Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +! Calculate the local-electrostatic correlation terms + do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,& +! ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1 + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 & + .or. j.lt.0 .and. j1.gt.0) .and. & + (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +! The system gains extra energy. + ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & + 'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +! Contacts I-J and I-(J+1) occur simultaneously. +! The system loses extra energy. +! ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +! & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +! Contacts I-J and (I+1)-J occur simultaneously. +! The system loses extra energy. +! ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end subroutine multibody_hb +!----------------------------------------------------------------------------- + subroutine add_hb_contact(ii,jj,itask) +! implicit real*8 (a-h,o-z) +! include "DIMENSIONS" +! include "COMMON.IOUNITS" +! include "COMMON.CONTACTS" +! integer,parameter :: maxconts=nres/4 + integer,parameter :: max_dim=26 + real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) +! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) +! common /przechowalnia/ zapas + integer :: i,j,ii,jj,iproc,nn,jjc + integer,dimension(4) :: itask +! write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +! write (iout,*) "i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,ii) + zapas(4,nn,iproc)=ees0p(j,ii) + zapas(5,nn,iproc)=ees0m(j,ii) + zapas(6,nn,iproc)=gacont_hbr(1,j,ii) + zapas(7,nn,iproc)=gacont_hbr(2,j,ii) + zapas(8,nn,iproc)=gacont_hbr(3,j,ii) + zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) + zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) + zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) + zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) + zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) + zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) + zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) + zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) + zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) + zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) + zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) + zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) + zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) + zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) + zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) + zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) + zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) + zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) + exit + endif + enddo + endif + enddo + return + end subroutine add_hb_contact +!----------------------------------------------------------------------------- + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +! This subroutine calculates multi-body contributions to hydrogen-bonding +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer,parameter :: max_dim=70 +#ifdef MPI + include "mpif.h" +! integer :: maxconts !max_cont=maxconts=nres/4 + integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) +! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) +! common /przechowalnia/ zapas + integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),& + status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,& + ierr,iii,nnn +#endif +! include 'COMMON.SETUP' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.CHAIN' +! include 'COMMON.CONTROL' + real(kind=8),dimension(3) :: gx,gx1 + integer,dimension(nres) :: num_cont_hb_old + logical :: lprn,ldone +!EL double precision eello4,eello5,eelo6,eello_turn6 +!EL external eello4,eello5,eello6,eello_turn6 +!el local variables + integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,& + j1,jp1,i1,num_conti1 + real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont + real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 + +! Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPI +! maxconts=nres/4 + if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks)) + do i=1,nres + num_cont_hb_old(i)=num_cont_hb(i) + enddo + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') & + i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& + j=1,num_cont_hb(i)) + enddo + endif + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +! write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +! & ntask_cont_to +! Make the list of contacts to send to send to other procesors + do i=iturn3_start,iturn3_end +! write (iout,*) "make contact list turn3",i," num_cont", +! & num_cont_hb(i) + call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +! write (iout,*) "make contact list turn4",i," num_cont", +! & num_cont_hb(i) + call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +! write (iout,*) "make contact list longrange",i,ii," num_cont", +! & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +! write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.ne.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,i) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) + enddo + enddo + enddo + enddo + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) & + "Numbers of contacts to be sent to other processors",& + (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc,& + " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +! Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,& + FG_COMM,req(ireq),IERR) + enddo +! write (iout,*) "IRECV ended" +! call flush(iout) +! Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,& + FG_COMM,req(ireq),IERR) + enddo +! write (iout,*) "ISEND ended" +! write (iout,*) "number of requests (nn)",ireq + call flush(iout) + if (ireq.gt.0) & + call MPI_Waitall(ireq,req,status_array,ierr) +! write (iout,*) +! & "Numbers of contacts to be received from other processors", +! & (ncont_recv(i),i=1,ntask_cont_from) +! call flush(iout) +! Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +! write (iout,*) "Receiving",nn," contacts from processor",iproc, +! & " of CONT_TO_COMM group" + call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,& + MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +! write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +! Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +! write (iout,*) nn," contacts to processor",iproc, +! & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,& + iproc,CorrelType1,FG_COMM,req(ireq),IERR) +! write (iout,*) "ireq,req",ireq,req(ireq) +! do i=1,nn +! write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +! enddo + endif + enddo +! write (iout,*) "number of requests (contacts)",ireq +! write (iout,*) "req",(req(i),i=1,4) +! call flush(iout) + if (ireq.gt.0) & + call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc,& + " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +! Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +! write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +! call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + d_cont(nnn,ii)=zapas_recv(3,i,iii) + ind=3 + do kk=1,3 + ind=ind+1 + grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,5f6.3))') & + i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),& + ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') & + i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),& + ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 + +! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) +! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) +! Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +! Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +! Calculate the local-electrostatic correlation terms +! write (iout,*) "gradcorr5 in eello5 before loop" +! do iii=1,nres +! write (iout,'(i5,3f10.5)') +! & iii,(gradcorr5(jjj,iii),jjj=1,3) +! enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +! write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +! & ' jj=',jj,' kk=',kk +! if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 & + .or. j.lt.0 .and. j1.gt.0) .and. & + (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +! The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr,& + ekont,fprimcont) +!d write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +!d & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +!d write (iout,*) 'sred_geom=',sred_geom, +!d & ' ekont=',ekont,' fprim=',fprimcont, +!d & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +!d write (iout,*) "g_contij",g_contij +!d write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +!d write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) & + ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) + if (energy_dec.and.wcorr4.gt.0.0d0) & + write (iout,'(a6,4i5,0pf7.3)') & + 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +! write (iout,*) "gradcorr5 before eello5" +! do iii=1,nres +! write (iout,'(i5,3f10.5)') +! & iii,(gradcorr5(jjj,iii),jjj=1,3) +! enddo + if (wcorr5.gt.0.0d0) & + ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +! write (iout,*) "gradcorr5 after eello5" +! do iii=1,nres +! write (iout,'(i5,3f10.5)') +! & iii,(gradcorr5(jjj,iii),jjj=1,3) +! enddo + if (energy_dec.and.wcorr5.gt.0.0d0) & + write (iout,'(a6,4i5,0pf7.3)') & + 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +!d write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +!d write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 & + .or. wturn6.eq.0.0d0))then +!d write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') & + 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +!d write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +!d & 'ecorr6=',ecorr6 +!d write (iout,'(4e15.5)') sred_geom, +!d & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +!d & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +!d & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 & + .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +!d write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') & + 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +!d write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +! write (iout,*) "gradcorr5 in eello5" +! do iii=1,nres +! write (iout,'(i5,3f10.5)') +! & iii,(gradcorr5(jjj,iii),jjj=1,3) +! enddo + return + end subroutine multibody_eello +!----------------------------------------------------------------------------- + subroutine add_hb_contact_eello(ii,jj,itask) +! implicit real*8 (a-h,o-z) +! include "DIMENSIONS" +! include "COMMON.IOUNITS" +! include "COMMON.CONTACTS" +! integer,parameter :: maxconts=nres/4 + integer,parameter :: max_dim=70 + real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) +! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) +! common /przechowalnia/ zapas + + integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm + integer,dimension(4) ::itask +! write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +! write (iout,*) "send turns i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,ii) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) + enddo + enddo + enddo + enddo + exit + endif + enddo + endif + enddo + return + end subroutine add_hb_contact_eello +!----------------------------------------------------------------------------- + real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' + real(kind=8),dimension(3) :: gx,gx1 + logical :: lprn +!el local variables + integer :: i,j,k,l,jj,kk,ll + real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,& + ees0mkl,ees,coeffpees0pij,coeffmees0mij,& + coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl + + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +!d ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +! Following 4 lines for diagnostics. +!d ees0pkl=0.0D0 +!d ees0pij=1.0D0 +!d ees0mkl=0.0D0 +!d ees0mij=1.0D0 +! write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +! & 'Contacts ',i,j, +! & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +! & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +! & 'gradcorr_long' +! Calculate the multi-body contribution to energy. +! ecorr=ecorr+ekont*ees +! Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +!grad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi + -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ & + coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi + -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ & + coeffmees0mkl*gacontm_hb2(ll,jj,i)) +!grad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk + -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+& + coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk + -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ & + coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- & + ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ & + coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- & + ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ & + coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +! write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +! write (iout,*) +!grad do m=i+1,j-1 +!grad do ll=1,3 +!grad gradcorr(ll,m)=gradcorr(ll,m)+ +!grad & ees*ekl*gacont_hbr(ll,jj,i)- +!grad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +!grad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +!grad enddo +!grad enddo +!grad do m=k+1,l-1 +!grad do ll=1,3 +!grad gradcorr(ll,m)=gradcorr(ll,m)+ +!grad & ees*eij*gacont_hbr(ll,kk,k)- +!grad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +!grad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +!grad enddo +!grad enddo +! write (iout,*) "ehbcorr",ekont*ees + ehbcorr=ekont*ees + return + end function ehbcorr +#ifdef MOMENT +!----------------------------------------------------------------------------- + subroutine dipole(i,j,jj) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8),dimension(2,2) :: dipi,dipj,auxmat + real(kind=8),dimension(2) :: dipderi,dipderj,auxvec + integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1 + + allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres)) + allocate(dipderx(3,5,4,maxconts,nres)) +! + + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,iti1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,itj1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),& + auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end subroutine dipole +#endif +!----------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +! +! This subroutine computes matrices and vectors needed to calculate +! the fourth-, fifth-, and sixth-order local-electrostatic terms. +! + use comm_kut +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.FFIELD' + real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat + real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder + integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,& + itj1 +!el logical :: lprn +!el common /kutas/ lprn +!d write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +!d & ' jj=',jj,' kk=',kk +!d if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +!d write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +!d write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),& + aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),& + aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +! parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +! A1 kernel(j+1) A2T +!d do iii=1,2 +!d write (iout,'(3f10.5,5x,3f10.5)') +!d & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +!d enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),& + AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +! Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),& + AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),& + Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),& + ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),& + DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),& + ADtEA1derx(1,1,1,1,1,1)) + ENDIF +! End 6-th order cumulants +!d lprn=.false. +!d if (lprn) then +!d write (2,*) 'In calc_eello6' +!d do iii=1,2 +!d write (2,*) 'iii=',iii +!d do kkk=1,5 +!d write (2,*) 'kkk=',kkk +!d do jjj=1,2 +!d write (2,'(3(2f10.5),5x)') +!d & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +!d enddo +!d enddo +!d enddo +!d endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),& + EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +! A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& + a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),& + AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +! Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& + a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),& + AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& + a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),& + Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),& + ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& + a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),& + DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),& + ADtEA1derx(1,1,1,1,1,2)) + ENDIF +! End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& + EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +! AEAb1 and AEAb2 +! Calculate the vectors and their derivatives in virtual-bond dihedral angles. +! They are needed only when the fifth- or the sixth-order cumulants are +! indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +! Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),& + AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),& + AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),& + AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),& + AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),& + AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),& + AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),& + AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),& + AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +! End vectors + else +! Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +! A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),& + AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +! Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. & + j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),& + AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),& + Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),& + ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& + aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),& + DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),& + ADtEA1derx(1,1,1,1,1,1)) + ENDIF +! End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),& + EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +! A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& + a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),& + AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +! Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. & + j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& + a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),& + AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& + a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),& + Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),& + ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& + a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),& + DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),& + ADtEA1derx(1,1,1,1,1,2)) + ENDIF +! End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& + EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +! AEAb1 and AEAb2 +! Calculate the vectors and their derivatives in virtual-bond dihedral angles. +! They are needed only when the fifth- or the sixth-order cumulants are +! indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. & + (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +! Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),& + AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),& + AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),& + AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),& + AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),& + AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),& + AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),& + AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),& + AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +! End vectors + endif + return + end subroutine calc_eello +!----------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx) + use comm_kut + implicit none + integer :: nderg + logical :: transp + real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA + real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx + real(kind=8),dimension(2,2,3,5,2) :: AKAderx + real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg + integer :: iii,kkk,lll + integer :: jjj,mmm +!el logical :: lprn +!el common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,& + AKAderg(1,1,iii)) + enddo +!d if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +!d if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),& + KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +!d if (lprn) then +!d write (2,*) 'lll=',lll +!d write (2,*) 'iii=1' +!d do jjj=1,2 +!d write (2,'(3(2f10.5),5x)') +!d & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +!d enddo +!d endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),& + KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +!d if (lprn) then +!d write (2,*) 'lll=',lll +!d write (2,*) 'iii=2' +!d do jjj=1,2 +!d write (2,'(3(2f10.5),5x)') +!d & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +!d enddo +!d endif + enddo + enddo + return + end subroutine kernel +!----------------------------------------------------------------------------- + real(kind=8) function eello4(i,j,k,l,jj,kk) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8),dimension(2,2) :: pizda + real(kind=8),dimension(3) :: ggg1,ggg2 + real(kind=8) :: eel4,glongij,glongkl + integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll +!d if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +!d eello4=0.0d0 +!d return +!d endif +!d print *,'eello4:',i,j,k,l,jj,kk +!d write (2,*) 'i',i,' j',j,' k',k,' l',l +!d call checkint4(i,j,k,l,jj,kk,eel4_num) +!old eij=facont_hb(jj,i) +!old ekl=facont_hb(kk,k) +!old ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) +!d eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) & + -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) & + -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) & + -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) & + -EAEAderx(2,2,lll,kkk,iii,1) +!d derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +!d gcorr_loc(l-1)=0.0d0 +!d gcorr_loc(j-1)=0.0d0 +!d gcorr_loc(k-1)=0.0d0 +!d eel4=1.0d0 +!d write (iout,*)'Contacts have occurred for peptide groups', +!d & i,j,' fcont:',eij,' eij',' and ',k,l, +!d & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +!grad ggg1(ll)=eel4*g_contij(ll,1) +!grad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +!grad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +!grad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +!grad do m=i+1,j-1 +!grad do ll=1,3 +!grad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +!grad enddo +!grad enddo +!grad do m=k+1,l-1 +!grad do ll=1,3 +!grad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +!grad enddo +!grad enddo +!grad do m=i+2,j2 +!grad do ll=1,3 +!grad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +!grad enddo +!grad enddo +!grad do m=k+2,l2 +!grad do ll=1,3 +!grad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +!grad enddo +!grad enddo +!d do iii=1,nres-3 +!d write (2,*) iii,gcorr_loc(iii) +!d enddo + eello4=ekont*eel4 +!d write (2,*) 'ekont',ekont +!d write (iout,*) 'eello4',ekont*eel4 + return + end function eello4 +!----------------------------------------------------------------------------- + real(kind=8) function eello5(i,j,k,l,jj,kk) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 + real(kind=8),dimension(2) :: vv + real(kind=8),dimension(3) :: ggg1,ggg2 + real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5 + real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf + integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! C +! Parallel chains C +! C +! o o o o C +! /l\ / \ \ / \ / \ / C +! / \ / \ \ / \ / \ / C +! j| o |l1 | o | o| o | | o |o C +! \ |/k\| |/ \| / |/ \| |/ \| C +! \i/ \ / \ / / \ / \ C +! o k1 o C +! (I) (II) (III) (IV) C +! C +! eello5_1 eello5_2 eello5_3 eello5_4 C +! C +! Antiparallel chains C +! C +! o o o o C +! /j\ / \ \ / \ / \ / C +! / \ / \ \ / \ / \ / C +! j1| o |l | o | o| o | | o |o C +! \ |/k\| |/ \| / |/ \| |/ \| C +! \i/ \ / \ / / \ / \ C +! o k1 o C +! (I) (II) (III) (IV) C +! C +! eello5_1 eello5_2 eello5_3 eello5_4 C +! C +! o denotes a local interaction, vertical lines an electrostatic interaction. C +! C +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!d if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +!d eello5=0.0d0 +!d return +!d endif +!d write (iout,*) +!d & 'EELLO5: Contacts have occurred for peptide groups',i,j, +!d & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +!d call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +!d & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +!d eij=facont_hb(jj,i) +!d ekl=facont_hb(kk,k) +!d ekont=eij*ekl +!d write (iout,*)'Contacts have occurred for peptide groups', +!d & i,j,' fcont:',eij,' eij',' and ',k,l +!d goto 1111 +! Contribution from the graph I. +!d write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +!d write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,i)) +! Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) & + +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) & + +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) & + +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) & + +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) & + +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +! Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),& + pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) & + +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +! goto 1112 +!1111 continue +! Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) & + -0.5d0*scalar2(vv(1),Ctobr(1,k)) +! Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) & + -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) & + +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) & + -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) & + +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) & + -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +! Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),& + pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) & + +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) & + -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +!d goto 1112 +!d1111 continue + if (l.eq.j+1) then +!d goto 1110 +! Parallel orientation +! Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,j)) +! Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) & + +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) & + +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) & + +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) & + +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +! Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),& + pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) & + +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +!d goto 1112 +! Contribution from graph IV +!d1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) & + -0.5d0*scalar2(vv(1),Ctobr(1,l)) +! Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) & + -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) & + +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) & + -0.5d0*scalar2(vv(1),Ctobr(1,l))) +! Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& + pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) & + +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) & + -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + else +! Antiparallel orientation +! Contribution from graph III +! goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,l)) +! Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) & + +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) & + +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) & + +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) & + +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +! Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),& + pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) & + +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) & + +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +!d goto 1112 +! Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) & + -0.5d0*scalar2(vv(1),Ctobr(1,j)) +! Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) & + -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) & + +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) & + -0.5d0*scalar2(vv(1),Ctobr(1,j))) +! Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& + pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) & + +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) & + -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +!d if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +!d write (2,*) 'ijkl',i,j,k,l +!d write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +!d & ' eello5_3',eello5_3,' eello5_4',eello5_4 +!d endif +!d write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +!d write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +!d write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +!d write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +!d eij=1.0d0 +!d ekl=1.0d0 +!d ekont=1.0d0 +!d write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +! 2/11/08 AL Gradients over DC's connecting interacting sites will be +! summed up outside the subrouine as for the other subroutines +! handling long-range interactions. The old code is commented out +! with "cgrad" to keep track of changes. + do ll=1,3 +!grad ggg1(ll)=eel5*g_contij(ll,1) +!grad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +! write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +! & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +! & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +! & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +! write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +! & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +! & gradcorr5ij, +! & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +!old ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +!grad ghalf=0.5d0*ggg1(ll) +!d ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +!old ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +!grad ghalf=0.5d0*ggg2(ll) + ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl + gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl + enddo +!d goto 1112 +!grad do m=i+1,j-1 +!grad do ll=1,3 +!old gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +!grad enddo +!grad enddo +!grad do m=k+1,l-1 +!grad do ll=1,3 +!old gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +!grad enddo +!grad enddo +!1112 continue +!grad do m=i+2,j2 +!grad do ll=1,3 +!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +!grad enddo +!grad enddo +!grad do m=k+2,l2 +!grad do ll=1,3 +!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +!grad enddo +!grad enddo +!d do iii=1,nres-3 +!d write (2,*) iii,g_corr5_loc(iii) +!d enddo + eello5=ekont*eel5 +!d write (2,*) 'ekont',ekont +!d write (iout,*) 'eello5',ekont*eel5 + return + end function eello5 +!----------------------------------------------------------------------------- + real(kind=8) function eello6(i,j,k,l,jj,kk) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.FFIELD' + real(kind=8),dimension(3) :: ggg1,ggg2 + real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,& + eello6_6,eel6 + real(kind=8) :: gradcorr6ij,gradcorr6kl + integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll +!d if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +!d eello6=0.0d0 +!d return +!d endif +!d write (iout,*) +!d & 'EELLO6: Contacts have occurred for peptide groups',i,j, +!d & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +!d call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +!d & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +!d eij=facont_hb(jj,i) +!d ekl=facont_hb(kk,k) +!d ekont=eij*ekl +!d eij=1.0d0 +!d ekl=1.0d0 +!d ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +! If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +!d write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +!d write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +!d write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +!d write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +!d write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +!d write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +!d goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +!grad ggg1(ll)=eel6*g_contij(ll,1) +!grad ggg2(ll)=eel6*g_contij(ll,2) +!old ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +!grad ghalf=0.5d0*ggg1(ll) +!d ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +!grad ghalf=0.5d0*ggg2(ll) +!old ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +!d ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo +!d goto 1112 +!grad do m=i+1,j-1 +!grad do ll=1,3 +!old gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +!grad enddo +!grad enddo +!grad do m=k+1,l-1 +!grad do ll=1,3 +!old gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +!grad enddo +!grad enddo +!grad1112 continue +!grad do m=i+2,j2 +!grad do ll=1,3 +!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +!grad enddo +!grad enddo +!grad do m=k+2,l2 +!grad do ll=1,3 +!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +!grad enddo +!grad enddo +!d do iii=1,nres-3 +!d write (2,*) iii,g_corr6_loc(iii) +!d enddo + eello6=ekont*eel6 +!d write (2,*) 'ekont',ekont +!d write (iout,*) 'eello6',ekont*eel6 + return + end function eello6 +!----------------------------------------------------------------------------- + real(kind=8) function eello6_graph1(i,j,k,l,imat,swap) + use comm_kut +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8),dimension(2) :: vv,vv1 + real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1 + logical :: swap +!el logical :: lprn +!el common /kutas/ lprn + integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind + real(kind=8) :: s1,s2,s3,s4,s5 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! C +! Parallel Antiparallel C +! C +! o o C +! /l\ /j\ C +! / \ / \ C +! /| o | | o |\ C +! \ j|/k\| / \ |/k\|l / C +! \ / \ / \ / \ / C +! o o o o C +! i i C +! C +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +!d write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) & + -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) & + -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) & + +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) & + +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) & + +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) & + +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) & + -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) & + +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) & + +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) & + +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) & + -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) & + +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) & + +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) & + +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) & + +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) & + +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),& + pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) & + -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) & + +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end function eello6_graph1 +!----------------------------------------------------------------------------- + real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap) + use comm_kut +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + logical :: swap + real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2 + real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 +!el logical :: lprn +!el common /kutas/ lprn + integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm + real(kind=8) :: s2,s3,s4 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! C +! Parallel Antiparallel C +! C +! o o C +! \ /l\ /j\ / C +! \ / \ / \ / C +! o| o | | o |o C +! \ j|/k\| \ |/k\|l C +! \ / \ \ / \ C +! o o C +! i i C +! C +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!d write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +! AL 7/4/01 s1 would occur in the sixth-order moment, +! but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +!d write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +! eello6_graph2=-s3 +! Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +! g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +! Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +! g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +! Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +! g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +! Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +! g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +! Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') & + ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),& + auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),& + auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),& + pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +!d write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end function eello6_graph2 +!----------------------------------------------------------------------------- + real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8),dimension(2) :: vv,auxvec + real(kind=8),dimension(2,2) :: pizda,auxmat + logical :: swap + integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1 + real(kind=8) :: s1,s2,s3,s4 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! C +! Parallel Antiparallel C +! C +! o o C +! /l\ / \ /j\ C +! / \ / \ / \ C +! /| o |o o| o |\ C +! j|/k\| / |/k\|l / C +! / \ / / \ / C +! / o / o C +! i i C +! C +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! 4/7/01 AL Component s1 was removed, because it pertains to the respective +! energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +!d write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +!d & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +! eello6_graph3=-s4 +! Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +! Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +! Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),& + auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),& + auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),& + pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +! derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end function eello6_graph3 +!----------------------------------------------------------------------------- + real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.FFIELD' + real(kind=8),dimension(2) :: vv,auxvec,auxvec1 + real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 + logical :: swap + integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,& + iii,kkk,lll + real(kind=8) :: s1,s2,s3,s4 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! C +! Parallel Antiparallel C +! C +! o o C +! /l\ / \ /j\ C +! / \ / \ / \ C +! /| o |o o| o |\ C +! \ j|/k\| \ |/k\|l C +! \ / \ \ / \ C +! o \ o \ C +! i i C +! C +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! 4/7/01 AL Component s1 was removed, because it pertains to the respective +! energy moment and not to the cluster cumulant. +!d write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + if (k.lt.nres-1) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +!d write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +!d write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +!d & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +!d write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +! Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +!d write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +! Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +! Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +! Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),& + auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),& + b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),& + b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),& + pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) & + -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) & + -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end function eello6_graph4 +!----------------------------------------------------------------------------- + real(kind=8) function eello_turn6(i,jj,kk) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec + real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp + real(kind=8),dimension(3) :: ggg1,ggg2 + real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd + real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd +! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +! the respective energy moment and not to the cluster cumulant. +!el local variables + integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll + integer :: j1,j2,l1,l2,ll + real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6 + real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +! + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +!d write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +!d write (2,*) 'i',i,' k',k,' j',j,' l',l +!d if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +!d eello6=0.0d0 +!d return +!d endif +!d write (iout,*) +!d & 'EELLO6: Contacts have occurred for peptide groups',i,j, +!d & ' and',k,l +!d call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +!d eij=1.0d0 +!d ekl=1.0d0 +!d ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +!d eello6_5=0.0d0 +!d write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,itk),vtemp1(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atemp(1,1)) + call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) + call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) + s12 = scalar2(Ub2(1,i+2),vtemp3(1)) +#ifdef MOMENT + call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) + call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) + call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) + ss13 = scalar2(b1(1,itk),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +! write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +! s1=0.0d0 +! s2=0.0d0 +! s8=0.0d0 +! s12=0.0d0 +! s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +! Derivatives in gamma(i+2) + s1d =0.0d0 + s8d =0.0d0 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +! s1d=0.0d0 +! s2d=0.0d0 +! s8d=0.0d0 +! s12d=0.0d0 +! s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +! Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +! s1d=0.0d0 +! s2d=0.0d0 +! s8d=0.0d0 +! s12d=0.0d0 +! s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) & + -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) & + -0.5d0*ekont*(s2d+s12d) +#endif +! Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +! s1d=0.0d0 +! s2d=0.0d0 +! s8d=0.0d0 +! s12d=0.0d0 +! s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +! Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +! s1d=0.0d0 +! s2d=0.0d0 +! s8d=0.0d0 +! s12d=0.0d0 +! s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) & + -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) & + -0.5d0*ekont*(s2d+s12d) +#endif +! Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),& + vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))* & + scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),& + auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +! s1d=0.0d0 +! s2d=0.0d0 +! s8d=0.0d0 +! s12d=0.0d0 +! s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) & + - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) & + - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) & + - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) & + - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),& + achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),& + vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +!d write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +!d & 16*eel_turn6_num +!d goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +!grad ggg1(ll)=eel_turn6*g_contij(ll,1) +!grad ggg2(ll)=eel_turn6*g_contij(ll,2) +!grad ghalf=0.5d0*ggg1(ll) +!d ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf + +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf + +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +!grad ghalf=0.5d0*ggg2(ll) +!d ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf + +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf + +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +!d goto 1112 +!grad do m=i+1,j-1 +!grad do ll=1,3 +!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +!grad enddo +!grad enddo +!grad do m=k+1,l-1 +!grad do ll=1,3 +!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +!grad enddo +!grad enddo +!grad1112 continue +!grad do m=i+2,j2 +!grad do ll=1,3 +!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +!grad enddo +!grad enddo +!grad do m=k+2,l2 +!grad do ll=1,3 +!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +!grad enddo +!grad enddo +!d do iii=1,nres-3 +!d write (2,*) iii,g_corr6_loc(iii) +!d enddo + eello_turn6=ekont*eel_turn6 +!d write (2,*) 'ekont',ekont +!d write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end function eello_turn6 +!----------------------------------------------------------------------------- + subroutine MATVEC2(A1,V1,V2) +!DIR$ INLINEALWAYS MATVEC2 +#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::MATVEC2 +#endif +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + real(kind=8),dimension(2) :: V1,V2 + real(kind=8),dimension(2,2) :: A1 + real(kind=8) :: vaux1,vaux2 +! DO 1 I=1,2 +! VI=0.0 +! DO 3 K=1,2 +! 3 VI=VI+A1(I,K)*V1(K) +! Vaux(I)=VI +! 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + end subroutine MATVEC2 +!----------------------------------------------------------------------------- + subroutine MATMAT2(A1,A2,A3) +#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::MATMAT2 +#endif +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + real(kind=8),dimension(2,2) :: A1,A2,A3 + real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22 +! DIMENSION AI3(2,2) +! DO J=1,2 +! A3IJ=0.0 +! DO K=1,2 +! A3IJ=A3IJ+A1(I,K)*A2(K,J) +! enddo +! A3(I,J)=A3IJ +! enddo +! enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + end subroutine MATMAT2 +!----------------------------------------------------------------------------- + real(kind=8) function scalar2(u,v) +!DIR$ INLINEALWAYS scalar2 + implicit none + real(kind=8),dimension(2) :: u,v + real(kind=8) :: sc + integer :: i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end function scalar2 +!----------------------------------------------------------------------------- + subroutine transpose2(a,at) +!DIR$ INLINEALWAYS transpose2 +#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::transpose2 +#endif + implicit none + real(kind=8),dimension(2,2) :: a,at + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end subroutine transpose2 +!----------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer :: n,i,j + real(kind=8),dimension(n,n) :: a,at + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end subroutine transpose +!----------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) +!DIR$ INLINEALWAYS prodmat3 +#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::prodmat3 +#endif + implicit none + integer :: i,j + real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod + logical :: transp +!rc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +!rc call transpose2(kk(1,1),auxmat(1,1)) +!rc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +!rc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) & + +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) & + +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) & + +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) & + +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +!rc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +!rc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) & + +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) & + +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) & + +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) & + +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +! call transpose2(a2(1,1),a2t(1,1)) + +!rc print *,transp +!rc print *,((prod_(i,j),i=1,2),j=1,2) +!rc print *,((prod(i,j),i=1,2),j=1,2) + + return + end subroutine prodmat3 +!----------------------------------------------------------------------------- +! energy_p_new_barrier.F +!----------------------------------------------------------------------------- + subroutine sum_gradient +! implicit real*8 (a-h,o-z) + use io_base, only: pdbout +! include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include 'mpif.h' +#endif + real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,& + gloc_scbuf !(3,maxres) + + real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres) +!#endif +!el local variables + integer :: i,j,k,ierror,ierr + real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,& + gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,& + gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,& + gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,& + gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,& + gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,& + gsccorr_max,gsccorrx_max,time00 + +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.CONTROL' +! include 'COMMON.TIME1' +! include 'COMMON.MAXGRAD' +! include 'COMMON.SCCOR' +#ifdef TIMING + time01=MPI_Wtime() +#endif +#ifdef DEBUG + write (iout,*) "sum_gradient gvdwc, gvdwx" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & + i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + gradbufc=0.0d0 + gradbufx=0.0d0 + gradbufc_sum=0.0d0 + gloc_scbuf=0.0d0 + glocbuf=0.0d0 +! FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (nfgtasks.gt.1 .and. fg_rank.eq.0) & + call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +! +! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient +! in virtual-bond-vector coordinates +! +#ifdef DEBUG +! write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" +! do i=1,nres-1 +! write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') +! & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) +! enddo +! write (iout,*) "gel_loc_tur3 gel_loc_turn4" +! do i=1,nres-1 +! write (iout,'(i5,3f10.5,2x,f10.5)') +! & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) +! enddo + write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & + i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),& + (gvdwc_scpp(j,i),j=1,3) + enddo + write (iout,*) "gelc_long gvdwpp gel_loc_long" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & + i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),& + (gelc_loc_long(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef SPLITELE + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+ & + wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ & + welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ & + wel_loc*gel_loc_long(j,i)+ & + wcorr*gradcorr_long(j,i)+ & + wcorr5*gradcorr5_long(j,i)+ & + wcorr6*gradcorr6_long(j,i)+ & + wturn6*gcorr6_turn_long(j,i)+ & + wstrain*ghpbc(j,i) + enddo + enddo +#else + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+ & + wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ & + welec*gelc_long(j,i)+ & + wbond*gradb(j,i)+ & + wel_loc*gel_loc_long(j,i)+ & + wcorr*gradcorr_long(j,i)+ & + wcorr5*gradcorr5_long(j,i)+ & + wcorr6*gradcorr6_long(j,i)+ & + wturn6*gcorr6_turn_long(j,i)+ & + wstrain*ghpbc(j,i) + enddo + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +#ifdef DEBUG + write (iout,*) "gradbufc before allreduce" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + enddo + enddo +! call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, +! & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +! time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG +! write (iout,*) "gradbufc_sum after allreduce" +! do i=1,nres +! write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) +! enddo +! call flush(iout) +#endif +#ifdef TIMING +! time_allreduce=time_allreduce+MPI_Wtime()-time00 +#endif + do i=nnt,nres + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + enddo +#ifdef DEBUG + write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end + write (iout,*) (i," jgrad_start",jgrad_start(i),& + " jgrad_end ",jgrad_end(i),& + i=igrad_start,igrad_end) +#endif +! +! Obsolete and inefficient code; we can make the effort O(n) and, therefore, +! do not parallelize this part. +! +! do i=igrad_start,igrad_end +! do j=jgrad_start(i),jgrad_end(i) +! do k=1,3 +! gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) +! enddo +! enddo +! enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,nnt,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + else +#endif +!el#define DEBUG +#ifdef DEBUG + write (iout,*) "gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif +!el#undef DEBUG + do i=1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + gradbufc(j,i)=0.0d0 + enddo + enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,nnt,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +! do i=nnt,nres-1 +! do k=1,3 +! gradbufc(k,i)=0.0d0 +! enddo +! do j=i+1,nres +! do k=1,3 +! gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) +! enddo +! enddo +! enddo +!el#define DEBUG +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif +!el#undef DEBUG +#ifdef MPI + endif +#endif + do k=1,3 + gradbufc(k,nres)=0.0d0 + enddo +!el---------------- +!el if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2) +!el if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2) +!el----------------- + do i=1,nct + do j=1,3 +#ifdef SPLITELE + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ & + wel_loc*gel_loc(j,i)+ & + 0.5d0*(wscp*gvdwc_scpp(j,i)+ & + welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ & + wel_loc*gel_loc_long(j,i)+ & + wcorr*gradcorr_long(j,i)+ & + wcorr5*gradcorr5_long(j,i)+ & + wcorr6*gradcorr6_long(j,i)+ & + wturn6*gcorr6_turn_long(j,i))+ & + wbond*gradb(j,i)+ & + wcorr*gradcorr(j,i)+ & + wturn3*gcorr3_turn(j,i)+ & + wturn4*gcorr4_turn(j,i)+ & + wcorr5*gradcorr5(j,i)+ & + wcorr6*gradcorr6(j,i)+ & + wturn6*gcorr6_turn(j,i)+ & + wsccor*gsccorc(j,i) & + +wscloc*gscloc(j,i) +#else + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ & + wel_loc*gel_loc(j,i)+ & + 0.5d0*(wscp*gvdwc_scpp(j,i)+ & + welec*gelc_long(j,i)+ & + wel_loc*gel_loc_long(j,i)+ & +!el wcorr*gcorr_long(j,i)+ & !el gcorr_long- brak deklaracji + wcorr5*gradcorr5_long(j,i)+ & + wcorr6*gradcorr6_long(j,i)+ & + wturn6*gcorr6_turn_long(j,i))+ & + wbond*gradb(j,i)+ & + wcorr*gradcorr(j,i)+ & + wturn3*gcorr3_turn(j,i)+ & + wturn4*gcorr4_turn(j,i)+ & + wcorr5*gradcorr5(j,i)+ & + wcorr6*gradcorr6(j,i)+ & + wturn6*gcorr6_turn(j,i)+ & + wsccor*gsccorc(j,i) & + +wscloc*gscloc(j,i) +#endif + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ & + wbond*gradbx(j,i)+ & + wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ & + wsccor*gsccorx(j,i) & + +wscloc*gsclocx(j,i) + enddo + enddo +#ifdef DEBUG + write (iout,*) "gloc before adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) & + +wcorr5*g_corr5_loc(i) & + +wcorr6*g_corr6_loc(i) & + +wturn4*gel_loc_turn4(i) & + +wturn3*gel_loc_turn3(i) & + +wturn6*gel_loc_turn6(i) & + +wel_loc*gel_loc_loc(i) + enddo +#ifdef DEBUG + write (iout,*) "gloc after adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + do j=1,3 + do i=1,nres + gradbufc(j,i)=gradc(j,i,icg) + gradbufx(j,i)=gradx(j,i,icg) + enddo + enddo + do i=1,4*nres + glocbuf(i)=gloc(i,icg) + enddo +!#define DEBUG +#ifdef DEBUG + write (iout,*) "gloc_sc before reduce" + do i=1,nres + do j=1,1 + write (iout,*) i,j,gloc_sc(j,i,icg) + enddo + enddo +#endif +!#undef DEBUG + do i=1,nres + do j=1,3 + gloc_scbuf(j,i)=gloc_sc(j,i,icg) + enddo + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_g=time_barrier_g+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,& + MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,& + MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,& + MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 + call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,& + MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +!#define DEBUG +#ifdef DEBUG + write (iout,*) "gloc_sc after reduce" + do i=1,nres + do j=1,1 + write (iout,*) i,j,gloc_sc(j,i,icg) + enddo + enddo +#endif +!#undef DEBUG +#ifdef DEBUG + write (iout,*) "gloc after reduce" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + endif +#endif + if (gnorm_check) then +! +! Compute the maximum elements of the gradient +! + gvdwc_max=0.0d0 + gvdwc_scp_max=0.0d0 + gelc_max=0.0d0 + gvdwpp_max=0.0d0 + gradb_max=0.0d0 + ghpbc_max=0.0d0 + gradcorr_max=0.0d0 + gel_loc_max=0.0d0 + gcorr3_turn_max=0.0d0 + gcorr4_turn_max=0.0d0 + gradcorr5_max=0.0d0 + gradcorr6_max=0.0d0 + gcorr6_turn_max=0.0d0 + gsccorc_max=0.0d0 + gscloc_max=0.0d0 + gvdwx_max=0.0d0 + gradx_scp_max=0.0d0 + ghpbx_max=0.0d0 + gradxorr_max=0.0d0 + gsccorx_max=0.0d0 + gsclocx_max=0.0d0 + do i=1,nct + gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm + gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) + if (gvdwc_scp_norm.gt.gvdwc_scp_max) & + gvdwc_scp_max=gvdwc_scp_norm + gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) + if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm + gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) + if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm + gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) + if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm + ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) + if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm + gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) + if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm + gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) + if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm + gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),& + gcorr3_turn(1,i))) + if (gcorr3_turn_norm.gt.gcorr3_turn_max) & + gcorr3_turn_max=gcorr3_turn_norm + gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),& + gcorr4_turn(1,i))) + if (gcorr4_turn_norm.gt.gcorr4_turn_max) & + gcorr4_turn_max=gcorr4_turn_norm + gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) + if (gradcorr5_norm.gt.gradcorr5_max) & + gradcorr5_max=gradcorr5_norm + gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) + if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm + gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),& + gcorr6_turn(1,i))) + if (gcorr6_turn_norm.gt.gcorr6_turn_max) & + gcorr6_turn_max=gcorr6_turn_norm + gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) + if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm + gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) + if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm + gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) + if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm + gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) + if (gradx_scp_norm.gt.gradx_scp_max) & + gradx_scp_max=gradx_scp_norm + ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) + if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm + gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) + if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm + gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) + if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm + gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) + if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm + enddo + if (gradout) then +#ifdef AIX + open(istat,file=statname,position="append") +#else + open(istat,file=statname,access="append") +#endif + write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,& + gelc_max,gvdwpp_max,gradb_max,ghpbc_max,& + gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,& + gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,& + gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,& + gsccorx_max,gsclocx_max + close(istat) + if (gvdwc_max.gt.1.0d4) then + write (iout,*) "gvdwc gvdwx gradb gradbx" + do i=nnt,nct + write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),& + gradb(j,i),gradbx(j,i),j=1,3) + enddo + call pdbout(0.0d0,'cipiszcze',iout) + call flush(iout) + endif + endif + endif +!el#define DEBUG +#ifdef DEBUG + write (iout,*) "gradc gradx gloc" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') & + i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +!el#undef DEBUG +#ifdef TIMING + time_sumgradient=time_sumgradient+MPI_Wtime()-time01 +#endif + return + end subroutine sum_gradient +!----------------------------------------------------------------------------- + subroutine sc_grad +! implicit real*8 (a-h,o-z) + use calc_data +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.CALC' +! include 'COMMON.IOUNITS' + real(kind=8), dimension(3) :: dcosom1,dcosom2 + + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & + -2.0D0*alf12*eps3der+sigder*sigsq_om12 +! diagnostics only +! eom1=0.0d0 +! eom2=0.0d0 +! eom12=evdwij*eps1_om12 +! end diagnostics +! write (iout,*) "eps2der",eps2der," eps3der",eps3der,& +! " sigder",sigder +! write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 +! write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + do k=1,3 + gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo +! write (iout,*) "gg",(gg(k),k=1,3) + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) & + +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & + +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) & + +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv +! write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +! +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv +! write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +! +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +! +! Calculate the components of the gradient in DC and X +! +!grad do k=i,j-1 +!grad do l=1,3 +!grad gvdwc(l,k)=gvdwc(l,k)+gg(l) +!grad enddo +!grad enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + return + end subroutine sc_grad +#ifdef CRYST_THETA +!----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + + use comm_calcthet +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.IOUNITS' +!el real(kind=8) :: term1,term2,termm,diffak,ratak,& +!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& +!el delthe0,sig0inv,sigtc,sigsqtc,delthec, + real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t + real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40 +!el integer :: it +!el common /calcthet/ term1,term2,termm,diffak,ratak,& +!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& +!el delthe0,sig0inv,sigtc,sigsqtc,delthec,it +!el local variables + + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +! "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 & + -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 & + *(-t12*t9-ak*sig0inv*t27) + return + end subroutine mixder +#endif +!----------------------------------------------------------------------------- +! cartder.F +!----------------------------------------------------------------------------- + subroutine cartder +!----------------------------------------------------------------------------- +! This subroutine calculates the derivatives of the consecutive virtual +! bond vectors and the SC vectors in the virtual-bond angles theta and +! virtual-torsional angles phi, as well as the derivatives of SC vectors +! in the angles alpha and omega, describing the location of a side chain +! in its local coordinate system. +! +! The derivatives are stored in the following arrays: +! +! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. +! The structure is as follows: +! +! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 +! dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) +! . . . . . . . . . . . . . . . . . . +! dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) +! . +! . +! . +! dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) +! +! DXDV - the derivatives of the side-chain vectors in theta and phi. +! The structure is same as above. +! +! DCDS - the derivatives of the side chain vectors in the local spherical +! andgles alph and omega: +! +! dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) +! dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) +! . +! . +! . +! dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) +! +! Version of March '95, based on an early version of November '91. +! +!********************************************************************** +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' + real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres) + real(kind=8),dimension(3,3) :: dp,temp +!el real(kind=8) :: fromto(3,3,maxdim) !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) + real(kind=8),dimension(3) :: xx,xx1 +!el local variables + integer :: i,k,l,j,m,ind,ind1,jjj + real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,& + tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,& + sint2,xp,yp,xxp,yyp,zzp,dj + +! common /przechowalnia/ fromto + if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim)) +! get the position of the jth ijth fragment of the chain coordinate system +! in the fromto array. +! indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +! +! maxdim=(nres-1)*(nres-2)/2 +! allocate(dcdv(6,maxdim),dxds(6,nres)) +! calculate the derivatives of transformation matrix elements in theta +! + +!el call flush(iout) !el + do i=1,nres-2 + rdt(1,1,i)=-rt(1,2,i) + rdt(1,2,i)= rt(1,1,i) + rdt(1,3,i)= 0.0d0 + rdt(2,1,i)=-rt(2,2,i) + rdt(2,2,i)= rt(2,1,i) + rdt(2,3,i)= 0.0d0 + rdt(3,1,i)=-rt(3,2,i) + rdt(3,2,i)= rt(3,1,i) + rdt(3,3,i)= 0.0d0 + enddo +! +! derivatives in phi +! + do i=2,nres-2 + drt(1,1,i)= 0.0d0 + drt(1,2,i)= 0.0d0 + drt(1,3,i)= 0.0d0 + drt(2,1,i)= rt(3,1,i) + drt(2,2,i)= rt(3,2,i) + drt(2,3,i)= rt(3,3,i) + drt(3,1,i)=-rt(2,1,i) + drt(3,2,i)=-rt(2,2,i) + drt(3,3,i)=-rt(2,3,i) + enddo +! +! generate the matrix products of type r(i)t(i)...r(j)t(j) +! + do i=2,nres-2 + ind=indmat(i,i+1) + do k=1,3 + do l=1,3 + temp(k,l)=rt(k,l,i) + enddo + enddo + do k=1,3 + do l=1,3 + fromto(k,l,ind)=temp(k,l) + enddo + enddo + do j=i+1,nres-2 + ind=indmat(i,j+1) + do k=1,3 + do l=1,3 + dpkl=0.0d0 + do m=1,3 + dpkl=dpkl+temp(k,m)*rt(m,l,j) + enddo + dp(k,l)=dpkl + fromto(k,l,ind)=dpkl + enddo + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + enddo + enddo +! +! Calculate derivatives. +! + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +! +! Derivatives of DC(i+1) in theta(i+2) +! + do j=1,3 + do k=1,2 + dpjk=0.0D0 + do l=1,3 + dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) + enddo + dp(j,k)=dpjk + prordt(j,k,i)=dp(j,k) + enddo + dp(j,3)=0.0D0 + dcdv(j,ind1)=vbld(i+1)*dp(j,1) + enddo +! +! Derivatives of SC(i+1) in theta(i+2) +! + xx1(1)=-0.5D0*xloc(2,i+1) + xx1(2)= 0.5D0*xloc(1,i+1) + do j=1,3 + xj=0.0D0 + do k=1,2 + xj=xj+r(j,k,i)*xx1(k) + enddo + xx(j)=xj + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j,ind1)=rj + enddo +! +! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +! than the other off-diagonal derivatives. +! + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j,ind1+1)=dxoiij + enddo +!d print *,ind1+1,(dxdv(j,ind1+1),j=1,3) +! +! Derivatives of DC(i+1) in phi(i+2) +! + do j=1,3 + do k=1,3 + dpjk=0.0 + do l=2,3 + dpjk=dpjk+prod(j,l,i)*drt(l,k,i) + enddo + dp(j,k)=dpjk + prodrt(j,k,i)=dp(j,k) + enddo + dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) + enddo +! +! Derivatives of SC(i+1) in phi(i+2) +! + xx(1)= 0.0D0 + xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) + xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) + do j=1,3 + rj=0.0D0 + do k=2,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j+3,ind1)=-rj + enddo +! +! Derivatives of SC(i+1) in phi(i+3). +! + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j+3,ind1+1)=dxoiij + enddo +! +! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru +! theta(nres) and phi(i+3) thru phi(nres). +! + do j=i+1,nres-2 + ind1=ind1+1 + ind=indmat(i+1,j+1) +!d print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,2 + tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) + enddo + temp(k,l)=tempkl + enddo + enddo +!d print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) +!d print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) +!d print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) +! Derivatives of virtual-bond vectors in theta + do k=1,3 + dcdv(k,ind1)=vbld(i+1)*temp(k,1) + enddo +!d print '(3f8.3)',(dcdv(k,ind1),k=1,3) +! Derivatives of SC vectors in theta + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k,ind1+1)=dxoijk + enddo +! +!--- Calculate the derivatives in phi +! + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) + enddo + temp(k,l)=tempkl + enddo + enddo + do k=1,3 + dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) + enddo + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k+3,ind1+1)=dxoijk + enddo + enddo + enddo +! +! Derivatives in alpha and omega: +! + do i=2,nres-1 +! dsci=dsc(itype(i)) + dsci=vbld(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) + if(alphi.ne.alphi) alphi=100.0 + if(omegi.ne.omegi) omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif +!d print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + temp(1,1)=-dsci*sinalphi + temp(2,1)= dsci*cosalphi*cosomegi + temp(3,1)=-dsci*cosalphi*sinomegi + temp(1,2)=0.0D0 + temp(2,2)=-dsci*sinalphi*sinomegi + temp(3,2)=-dsci*sinalphi*cosomegi + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + jjj=0 +!d print *,((temp(l,k),l=1,3),k=1,2) + do j=1,2 + xp=temp(1,j) + yp=temp(2,j) + xxp= xp*cost2+yp*sint2 + yyp=-xp*sint2+yp*cost2 + zzp=temp(3,j) + xx(1)=xxp + xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) + xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) + do k=1,3 + dj=0.0D0 + do l=1,3 + dj=dj+prod(k,l,i-1)*xx(l) + enddo + dxds(jjj+k,i)=dj + enddo + jjj=jjj+3 + enddo + enddo + return + end subroutine cartder +!----------------------------------------------------------------------------- +! checkder_p.F +!----------------------------------------------------------------------------- + subroutine check_cartgrad +! Check the gradient of Cartesian coordinates in internal coordinates. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.DERIV' + real(kind=8),dimension(6,nres) :: temp + real(kind=8),dimension(3) :: xx,gg + integer :: i,k,j,ii + real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii +! indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +! +! Check the gradient of the virtual-bond and SC vectors in the internal +! coordinates. +! + aincr=1.0d-7 + aincr2=5.0d-8 + call cartder + write (iout,'(a)') '**************** dx/dalpha' + write (iout,'(a)') + do i=2,nres-1 + alphi=alph(i) + alph(i)=alph(i)+aincr + do k=1,3 + temp(k,i)=dc(k,nres+i) + enddo + call chainbuild + do k=1,3 + gg(k)=(dc(k,nres+i)-temp(k,i))/aincr + xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) + enddo + write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') & + i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + alph(i)=alphi + call chainbuild + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/domega' + write (iout,'(a)') + do i=2,nres-1 + omegi=omeg(i) + omeg(i)=omeg(i)+aincr + do k=1,3 + temp(k,i)=dc(k,nres+i) + enddo + call chainbuild + do k=1,3 + gg(k)=(dc(k,nres+i)-temp(k,i))/aincr + xx(k)=dabs((gg(k)-dxds(k+3,i))/ & + (aincr*dabs(dxds(k+3,i))+aincr)) + enddo + write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') & + i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + omeg(i)=omegi + call chainbuild + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/dtheta' + write (iout,'(a)') + do i=3,nres + theti=theta(i) + theta(i)=theta(i)+aincr + do j=i-1,nres-1 + do k=1,3 + temp(k,j)=dc(k,nres+j) + enddo + enddo + call chainbuild + do j=i-1,nres-1 + ii = indmat(i-2,j) +! print *,'i=',i-2,' j=',j-1,' ii=',ii + do k=1,3 + gg(k)=(dc(k,nres+j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dxdv(k,ii))/ & + (aincr*dabs(dxdv(k,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & + i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) + write(iout,'(a)') + enddo + write (iout,'(a)') + theta(i)=theti + call chainbuild + enddo + write (iout,'(a)') '***************** dx/dphi' + write (iout,'(a)') + do i=4,nres + phi(i)=phi(i)+aincr + do j=i-1,nres-1 + do k=1,3 + temp(k,j)=dc(k,nres+j) + enddo + enddo + call chainbuild + do j=i-1,nres-1 + ii = indmat(i-2,j) +! print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,nres+j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ & + (aincr*dabs(dxdv(k+3,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & + i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) + write(iout,'(a)') + enddo + phi(i)=phi(i)-aincr + call chainbuild + enddo + write (iout,'(a)') '****************** ddc/dtheta' + do i=1,nres-2 + thet=theta(i+2) + theta(i+2)=thet+aincr + do j=i,nres + do k=1,3 + temp(k,j)=dc(k,j) + enddo + enddo + call chainbuild + do j=i+1,nres-1 + ii = indmat(i,j) +! print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dcdv(k,ii))/ & + (aincr*dabs(dcdv(k,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & + i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + enddo + do j=1,nres + do k=1,3 + dc(k,j)=temp(k,j) + enddo + enddo + theta(i+2)=thet + enddo + write (iout,'(a)') '******************* ddc/dphi' + do i=1,nres-3 + phii=phi(i+3) + phi(i+3)=phii+aincr + do j=1,nres + do k=1,3 + temp(k,j)=dc(k,j) + enddo + enddo + call chainbuild + do j=i+2,nres-1 + ii = indmat(i+1,j) +! print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ & + (aincr*dabs(dcdv(k+3,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & + i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + enddo + do j=1,nres + do k=1,3 + dc(k,j)=temp(k,j) + enddo + enddo + phi(i+3)=phii + enddo + return + end subroutine check_cartgrad +!----------------------------------------------------------------------------- + subroutine check_ecart +! Check the gradient of the energy in Cartesian coordinates. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.CONTACTS' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall + real(kind=8),dimension(6) :: ggg + real(kind=8),dimension(3) :: cc,xx,ddc,ddx + real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(6,nres) :: grad_s + real(kind=8),dimension(0:n_ene) :: energia,energia1 + integer :: uiparm(1) + real(kind=8) :: urparm(1) +!EL external fdum + integer :: nf,i,j,k + real(kind=8) :: aincr,etot,etot1 + icg=1 + nf=0 + nfl=0 + call zerograd + aincr=1.0D-7 + print '(a)','CG processor',me,' calling CHECK_CART.' + nf=0 + icall=0 + call geom_to_var(nvar,x) + call etotal(energia) + etot=energia(0) +!el call enerprint(energia) + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) + icall =1 + do i=1,nres + write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gradc(j,i,icg) + grad_s(j+3,i)=gradx(j,i,icg) + enddo + enddo + call flush(iout) + write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' + do i=1,nres + do j=1,3 + xx(j)=c(j,i+nres) + ddc(j)=dc(j,i) + ddx(j)=dc(j,i+nres) + enddo + do j=1,3 + dc(j,i)=dc(j,i)+aincr + do k=i+1,nres + c(j,k)=c(j,k)+aincr + c(j,k+nres)=c(j,k+nres)+aincr + enddo + call etotal(energia1) + etot1=energia1(0) + ggg(j)=(etot1-etot)/aincr + dc(j,i)=ddc(j) + do k=i+1,nres + c(j,k)=c(j,k)-aincr + c(j,k+nres)=c(j,k+nres)-aincr + enddo + enddo + do j=1,3 + c(j,i+nres)=c(j,i+nres)+aincr + dc(j,i+nres)=dc(j,i+nres)+aincr + call etotal(energia1) + etot1=energia1(0) + ggg(j+3)=(etot1-etot)/aincr + c(j,i+nres)=xx(j) + dc(j,i+nres)=ddx(j) + enddo + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') & + i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) + enddo + return + end subroutine check_ecart +!----------------------------------------------------------------------------- + subroutine check_ecartint +! Check the gradient of the energy in Cartesian coordinates. + use io_base, only: intout +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.CONTACTS' +! include 'COMMON.MD' +! include 'COMMON.LOCAL' +! include 'COMMON.SPLITELE' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall + real(kind=8),dimension(6) :: ggg,ggg1 + real(kind=8),dimension(3) :: cc,xx,ddc,ddx + real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe + real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres) + real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres) + real(kind=8),dimension(0:n_ene) :: energia,energia1 + integer :: uiparm(1) + real(kind=8) :: urparm(1) +!EL external fdum + integer :: i,j,k,nf + real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,& + etot21,etot22 + r_cut=2.0d0 + rlambd=0.3d0 + icg=1 + nf=0 + nfl=0 + call intout +! call intcartderiv +! call checkintcartgrad + call zerograd + aincr=1.0D-4 + write(iout,*) 'Calling CHECK_ECARTINT.' + nf=0 + icall=0 + call geom_to_var(nvar,x) + if (.not.split_ene) then + call etotal(energia) + etot=energia(0) +!el call enerprint(energia) + call flush(iout) + write (iout,*) "enter cartgrad" + call flush(iout) + call cartgrad + write (iout,*) "exit cartgrad" + call flush(iout) + icall =1 + do i=1,nres + write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) + enddo + do j=1,3 + grad_s(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gcart(j,i) + grad_s(j+3,i)=gxcart(j,i) + enddo + enddo + else +!- split gradient check + call zerograd + call etotal_long(energia) +!el call enerprint(energia) + call flush(iout) + write (iout,*) "enter cartgrad" + call flush(iout) + call cartgrad + write (iout,*) "exit cartgrad" + call flush(iout) + icall =1 + write (iout,*) "longrange grad" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& + (gxcart(j,i),j=1,3) + enddo + do j=1,3 + grad_s(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gcart(j,i) + grad_s(j+3,i)=gxcart(j,i) + enddo + enddo + call zerograd + call etotal_short(energia) +!el call enerprint(energia) + call flush(iout) + write (iout,*) "enter cartgrad" + call flush(iout) + call cartgrad + write (iout,*) "exit cartgrad" + call flush(iout) + icall =1 + write (iout,*) "shortrange grad" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& + (gxcart(j,i),j=1,3) + enddo + do j=1,3 + grad_s1(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s1(j,i)=gcart(j,i) + grad_s1(j+3,i)=gxcart(j,i) + enddo + enddo + endif + write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' + do i=0,nres + do j=1,3 + xx(j)=c(j,i+nres) + ddc(j)=dc(j,i) + ddx(j)=dc(j,i+nres) + do k=1,3 + dcnorm_safe(k)=dc_norm(k,i) + dxnorm_safe(k)=dc_norm(k,i+nres) + enddo + enddo + do j=1,3 + dc(j,i)=ddc(j)+aincr + call chainbuild_cart +#ifdef MPI +! Broadcast the order to compute internal coordinates to the slaves. +! if (nfgtasks.gt.1) +! & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +! call int_from_cart1(.false.) + if (.not.split_ene) then + call etotal(energia1) + etot1=energia1(0) + else +!- split gradient + call etotal_long(energia1) + etot11=energia1(0) + call etotal_short(energia1) + etot12=energia1(0) +! write (iout,*) "etot11",etot11," etot12",etot12 + endif +!- end split gradient +! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 + dc(j,i)=ddc(j)-aincr + call chainbuild_cart +! call int_from_cart1(.false.) + if (.not.split_ene) then + call etotal(energia1) + etot2=energia1(0) + ggg(j)=(etot1-etot2)/(2*aincr) + else +!- split gradient + call etotal_long(energia1) + etot21=energia1(0) + ggg(j)=(etot11-etot21)/(2*aincr) + call etotal_short(energia1) + etot22=energia1(0) + ggg1(j)=(etot12-etot22)/(2*aincr) +!- end split gradient +! write (iout,*) "etot21",etot21," etot22",etot22 + endif +! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 + dc(j,i)=ddc(j) + call chainbuild_cart + enddo + do j=1,3 + dc(j,i+nres)=ddx(j)+aincr + call chainbuild_cart +! write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" +! write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) +! write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) +! write (iout,*) "dxnormnorm",dsqrt( +! & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) +! write (iout,*) "dxnormnormsafe",dsqrt( +! & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) +! write (iout,*) + if (.not.split_ene) then + call etotal(energia1) + etot1=energia1(0) + else +!- split gradient + call etotal_long(energia1) + etot11=energia1(0) + call etotal_short(energia1) + etot12=energia1(0) + endif +!- end split gradient +! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 + dc(j,i+nres)=ddx(j)-aincr + call chainbuild_cart +! write (iout,*) "i",i," j",j," dxnorm- and dxnorm" +! write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) +! write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) +! write (iout,*) +! write (iout,*) "dxnormnorm",dsqrt( +! & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) +! write (iout,*) "dxnormnormsafe",dsqrt( +! & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) + if (.not.split_ene) then + call etotal(energia1) + etot2=energia1(0) + ggg(j+3)=(etot1-etot2)/(2*aincr) + else +!- split gradient + call etotal_long(energia1) + etot21=energia1(0) + ggg(j+3)=(etot11-etot21)/(2*aincr) + call etotal_short(energia1) + etot22=energia1(0) + ggg1(j+3)=(etot12-etot22)/(2*aincr) +!- end split gradient + endif +! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 + dc(j,i+nres)=ddx(j) + call chainbuild_cart + enddo + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & + i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) + if (split_ene) then + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & + i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),& + k=1,6) + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & + i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),& + ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) + endif + enddo + return + end subroutine check_ecartint +!----------------------------------------------------------------------------- + subroutine check_eint +! Check the gradient of energy in internal coordinates. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall + real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres) + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2 + character(len=6) :: key +!EL external fdum + integer :: i,ii,nf + real(kind=8) :: xi,aincr,etot,etot1,etot2 + call zerograd + aincr=1.0D-7 + print '(a)','Calling CHECK_INT.' + nf=0 + nfl=0 + icg=1 + call geom_to_var(nvar,x) + call var_to_geom(nvar,x) + call chainbuild + icall=1 + print *,'ICG=',ICG + call etotal(energia) + etot = energia(0) +!el call enerprint(energia) + print *,'ICG=',ICG +#ifdef MPL + if (MyID.ne.BossID) then + call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) + nf=x(nvar+1) + nfl=x(nvar+2) + icg=x(nvar+3) + endif +#endif + nf=1 + nfl=3 +!d write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) + call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) +!d write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp + icall=1 + do i=1,nvar + xi=x(i) + x(i)=xi-0.5D0*aincr + call var_to_geom(nvar,x) + call chainbuild + call etotal(energia1) + etot1=energia1(0) + x(i)=xi+0.5D0*aincr + call var_to_geom(nvar,x) + call chainbuild + call etotal(energia2) + etot2=energia2(0) + gg(i)=(etot2-etot1)/aincr + write (iout,*) i,etot1,etot2 + x(i)=xi + enddo + write (iout,'(/2a)')' Variable Numerical Analytical',& + ' RelDiff*100% ' + do i=1,nvar + if (i.le.nphi) then + ii=i + key = ' phi' + else if (i.le.nphi+ntheta) then + ii=i-nphi + key=' theta' + else if (i.le.nphi+ntheta+nside) then + ii=i-(nphi+ntheta) + key=' alpha' + else + ii=i-(nphi+ntheta+nside) + key=' omega' + endif + write (iout,'(i3,a,i3,3(1pd16.6))') & + i,key,ii,gg(i),gana(i),& + 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) + enddo + return + end subroutine check_eint +!----------------------------------------------------------------------------- +! econstr_local.F +!----------------------------------------------------------------------------- + subroutine Econstr_back +! MD with umbrella_sampling using Wolyne's distance measure as a constraint +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' + use MD_data +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + integer :: i,j,ii,k + real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz + + if(.not.allocated(utheta)) allocate(utheta(nfrag_back)) + if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back)) + if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back)) + + Uconst_back=0.0d0 + do i=1,nres + dutheta(i)=0.0d0 + dugamma(i)=0.0d0 + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo + do i=1,nfrag_back + ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +! +! Deviations from theta angles +! + utheta_i=0.0d0 + do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) + dtheta_i=theta(j)-thetaref(j) + utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i + dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) + enddo + utheta(i)=utheta_i/(ii-1) +! +! Deviations from gamma angles +! + ugamma_i=0.0d0 + do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) + dgamma_i=pinorm(phi(j)-phiref(j)) +! write (iout,*) j,phi(j),phi(j)-phiref(j) + ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i + dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) +! write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) + enddo + ugamma(i)=ugamma_i/(ii-2) +! +! Deviations from local SC geometry +! + uscdiff(i)=0.0d0 + do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 + dxx=xxtab(j)-xxref(j) + dyy=yytab(j)-yyref(j) + dzz=zztab(j)-zzref(j) + uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz + do k=1,3 + duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* & + (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ & + (ii-1) + duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* & + (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ & + (ii-1) + duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* & + (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) & + /(ii-1) + enddo +! write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +! & xxref(j),yyref(j),zzref(j) + enddo + uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) +! write (iout,*) i," uscdiff",uscdiff(i) +! +! Put together deviations from local geometry +! + Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ & + wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) +! write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), +! & " uconst_back",uconst_back + utheta(i)=dsqrt(utheta(i)) + ugamma(i)=dsqrt(ugamma(i)) + uscdiff(i)=dsqrt(uscdiff(i)) + enddo + return + end subroutine Econstr_back +!----------------------------------------------------------------------------- +! energy_p_new-sep_barrier.F +!----------------------------------------------------------------------------- + real(kind=8) function sscale(r) +! include "COMMON.SPLITELE" + real(kind=8) :: r,gamm + if(r.lt.r_cut-rlamb) then + sscale=1.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale=0d0 + endif + return + end function sscale +!----------------------------------------------------------------------------- + subroutine elj_long(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the LJ potential of interaction. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.TORSION' +! include 'COMMON.SBRIDGE' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTACTS' + real(kind=8),parameter :: accur=1.0d-10 + real(kind=8),dimension(3) :: gg +!el local variables + integer :: i,iint,j,k,itypi,itypi1,itypj + real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij + real(kind=8) :: e1,e2,evdwij,evdw +! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) +!d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +!d & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rij=xj*xj+yj*yj+zj*zj + sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + if (sss.lt.1.0d0) then + rrij=1.0D0/rij + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + evdw=evdw+(1.0d0-sss)*evdwij +! +! Calculate the components of the gradient in DC and X +! + fac=-rrij*(e1+evdwij)*(1.0d0-sss) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo +!****************************************************************************** +! +! N O T E !!! +! +! To save time, the factor of EXPON has been extracted from ALL components +! of GVDWC and GRADX. Remember to multiply them by this factor before further +! use! +! +!****************************************************************************** + return + end subroutine elj_long +!----------------------------------------------------------------------------- + subroutine elj_short(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the LJ potential of interaction. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.TORSION' +! include 'COMMON.SBRIDGE' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTACTS' + real(kind=8),parameter :: accur=1.0d-10 + real(kind=8),dimension(3) :: gg +!el local variables + integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti + real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij + real(kind=8) :: e1,e2,evdwij,evdw +! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +! Change 12/1/95 + num_conti=0 +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) +!d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +!d & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +! Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + if (sss.gt.0.0d0) then + rrij=1.0D0/rij + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + evdw=evdw+sss*evdwij +! +! Calculate the components of the gradient in DC and X +! + fac=-rrij*(e1+evdwij)*sss + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo +!****************************************************************************** +! +! N O T E !!! +! +! To save time, the factor of EXPON has been extracted from ALL components +! of GVDWC and GRADX. Remember to multiply them by this factor before further +! use! +! +!****************************************************************************** + return + end subroutine elj_short +!----------------------------------------------------------------------------- + subroutine eljk_long(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the LJK potential of interaction. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + real(kind=8),dimension(3) :: gg + logical :: scheck +!el local variables + integer :: i,iint,j,k,itypi,itypi1,itypj + real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,& + fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij +! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + r_inv_ij=dsqrt(rrij) + rij=1.0D0/r_inv_ij + sss=sscale(rij/sigma(itypi,itypj)) + if (sss.lt.1.0d0) then + r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) + fac=r_shift_inv**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e_augm+e1+e2 +!d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +!d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +!d write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') +!d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +!d & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, +!d & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, +!d & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+(1.0d0-sss)*evdwij +! +! Calculate the components of the gradient in DC and X +! + fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + fac=fac*(1.0d0-sss) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo + return + end subroutine eljk_long +!----------------------------------------------------------------------------- + subroutine eljk_short(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the LJK potential of interaction. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' + real(kind=8),dimension(3) :: gg + logical :: scheck +!el local variables + integer :: i,iint,j,k,itypi,itypi1,itypj + real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,& + fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij +! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + r_inv_ij=dsqrt(rrij) + rij=1.0D0/r_inv_ij + sss=sscale(rij/sigma(itypi,itypj)) + if (sss.gt.0.0d0) then + r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) + fac=r_shift_inv**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e_augm+e1+e2 +!d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +!d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +!d write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') +!d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +!d & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, +!d & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, +!d & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+sss*evdwij +! +! Calculate the components of the gradient in DC and X +! + fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + fac=fac*sss + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo + return + end subroutine eljk_short +!----------------------------------------------------------------------------- + subroutine ebp_long(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Berne-Pechukas potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall +! double precision rrsave(maxdim) + logical :: lprn +!el local variables + integer :: iint,itypi,itypi1,itypj + real(kind=8) :: rrij,xi,yi,zi,fac + real(kind=8) :: sss,e1,e2,evdw,sigm,epsi + evdw=0.0D0 +! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 +! if (icall.eq.0) then +! lprn=.true. +! else + lprn=.false. +! endif +!el ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) +!el ind=ind+1 + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.lt.1.0d0) then + +! Calculate the angle-dependent terms of energy & contributions to derivatives. + call sc_angular +! Calculate whole angle-dependent part of epsilon and contributions +! to its derivatives + fac=(rrij*sigsq)**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij*(1.0d0-sss) + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +!d write (iout,'(2(a3,i3,2x),15(0pf7.3))') +!d & restyp(itypi),i,restyp(itypj),j, +!d & epsi,sigm,chi1,chi2,chip1,chip2, +!d & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), +!d & om1,om2,om12,1.0D0/dsqrt(rrij), +!d & evdwij + endif +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij) + sigder=fac/sigsq + fac=rrij*fac +! Calculate radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate the angular part of the gradient and sum add the contributions +! to the appropriate components of the Cartesian gradient. + call sc_grad_scale(1.0d0-sss) + endif + enddo ! j + enddo ! iint + enddo ! i +! stop + return + end subroutine ebp_long +!----------------------------------------------------------------------------- + subroutine ebp_short(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Berne-Pechukas potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall +! double precision rrsave(maxdim) + logical :: lprn +!el local variables + integer :: iint,itypi,itypi1,itypj + real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi + real(kind=8) :: sss,e1,e2,evdw + evdw=0.0D0 +! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 +! if (icall.eq.0) then +! lprn=.true. +! else + lprn=.false. +! endif +!el ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) +!el ind=ind+1 + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.gt.0.0d0) then + +! Calculate the angle-dependent terms of energy & contributions to derivatives. + call sc_angular +! Calculate whole angle-dependent part of epsilon and contributions +! to its derivatives + fac=(rrij*sigsq)**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij*sss + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +!d write (iout,'(2(a3,i3,2x),15(0pf7.3))') +!d & restyp(itypi),i,restyp(itypj),j, +!d & epsi,sigm,chi1,chi2,chip1,chip2, +!d & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), +!d & om1,om2,om12,1.0D0/dsqrt(rrij), +!d & evdwij + endif +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij) + sigder=fac/sigsq + fac=rrij*fac +! Calculate radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate the angular part of the gradient and sum add the contributions +! to the appropriate components of the Cartesian gradient. + call sc_grad_scale(sss) + endif + enddo ! j + enddo ! iint + enddo ! i +! stop + return + end subroutine ebp_short +!----------------------------------------------------------------------------- + subroutine egb_long(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Gay-Berne potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' +! include 'COMMON.CONTROL' + logical :: lprn +!el local variables + integer :: iint,itypi,itypi1,itypj + real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift + real(kind=8) :: sss,e1,e2,evdw + evdw=0.0D0 +!cccc energy_dec=.false. +! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +! if (icall.eq.0) lprn=.false. +!el ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +! write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +! write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) +!el ind=ind+1 + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) +! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +! & 1.0d0/vbld(j+nres) +! write (iout,*) "i",i," j", j," itype",itype(i),itype(j) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.lt.1.0d0) then + +! Calculate angle-dependent terms of energy and contributions to their +! derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij +! for diagnostics; uncomment +! rij_shift=1.2*sig0ij +! I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 +!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') +!d & restyp(itypi),i,restyp(itypj),j, +!d & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) + return + endif + sigder=-sig*sigsq +!--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt +! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +! & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij*(1.0d0-sss) + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') & + restyp(itypi),i,restyp(itypj),j,& + epsi,sigm,chi1,chi2,chip1,chip2,& + eps1,eps2rt**2,eps3rt**2,sig,sig0ij,& + om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& + evdwij + endif + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & + 'evdw',i,j,evdwij +! if (energy_dec) write (iout,*) & +! 'evdw',i,j,evdwij,"egb_long" + +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac +! fac=0.0d0 +! Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate angular part of the gradient. + call sc_grad_scale(1.0d0-sss) + endif + enddo ! j + enddo ! iint + enddo ! i +! write (iout,*) "Number of loop steps in EGB:",ind +!ccc energy_dec=.false. + return + end subroutine egb_long +!----------------------------------------------------------------------------- + subroutine egb_short(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Gay-Berne potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' +! include 'COMMON.CONTROL' + logical :: lprn +!el local variables + integer :: iint,itypi,itypi1,itypj + real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig + real(kind=8) :: sss,e1,e2,evdw,rij_shift + evdw=0.0D0 +!cccc energy_dec=.false. +! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +! if (icall.eq.0) lprn=.false. +!el ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +! write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +! write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) +!el ind=ind+1 + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) +! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +! & 1.0d0/vbld(j+nres) +! write (iout,*) "i",i," j", j," itype",itype(i),itype(j) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.gt.0.0d0) then + +! Calculate angle-dependent terms of energy and contributions to their +! derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij +! for diagnostics; uncomment +! rij_shift=1.2*sig0ij +! I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 +!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') +!d & restyp(itypi),i,restyp(itypj),j, +!d & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) + return + endif + sigder=-sig*sigsq +!--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt +! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +! & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij*sss + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') & + restyp(itypi),i,restyp(itypj),j,& + epsi,sigm,chi1,chi2,chip1,chip2,& + eps1,eps2rt**2,eps3rt**2,sig,sig0ij,& + om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& + evdwij + endif + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & + 'evdw',i,j,evdwij +! if (energy_dec) write (iout,*) & +! 'evdw',i,j,evdwij,"egb_short" + +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac +! fac=0.0d0 +! Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate angular part of the gradient. + call sc_grad_scale(sss) + endif + enddo ! j + enddo ! iint + enddo ! i +! write (iout,*) "Number of loop steps in EGB:",ind +!ccc energy_dec=.false. + return + end subroutine egb_short +!----------------------------------------------------------------------------- + subroutine egbv_long(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Gay-Berne-Vorobjev potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall + logical :: lprn +!el local variables + integer :: iint,itypi,itypi1,itypj + real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij + real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift + evdw=0.0D0 +! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +! if (icall.eq.0) lprn=.true. +!el ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) +!el ind=ind+1 + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + sig0ij=sigma(itypi,itypj) + r0ij=r0(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.lt.1.0d0) then + +! Calculate angle-dependent terms of energy and contributions to their +! derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+r0ij +! I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 + return + endif + sigder=-sig*sigsq +!--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') & + restyp(itypi),i,restyp(itypj),j,& + epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),& + chi1,chi2,chip1,chip2,& + eps1,eps2rt**2,eps3rt**2,& + om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& + evdwij+e_augm + endif +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac-2*expon*rrij*e_augm +! Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate angular part of the gradient. + call sc_grad_scale(1.0d0-sss) + endif + enddo ! j + enddo ! iint + enddo ! i + end subroutine egbv_long +!----------------------------------------------------------------------------- + subroutine egbv_short(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Gay-Berne-Vorobjev potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' + use comm_srutu +!el integer :: icall +!el common /srutu/ icall + logical :: lprn +!el local variables + integer :: iint,itypi,itypi1,itypj + real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift + real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm + evdw=0.0D0 +! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +! if (icall.eq.0) lprn=.true. +!el ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + if (itypi.eq.ntyp1) cycle + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +! dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) +!el ind=ind+1 + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + sig0ij=sigma(itypi,itypj) + r0ij=r0(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.gt.0.0d0) then + +! Calculate angle-dependent terms of energy and contributions to their +! derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+r0ij +! I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 + return + endif + sigder=-sig*sigsq +!--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+(evdwij+e_augm)*sss + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') & + restyp(itypi),i,restyp(itypj),j,& + epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),& + chi1,chi2,chip1,chip2,& + eps1,eps2rt**2,eps3rt**2,& + om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& + evdwij+e_augm + endif +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac-2*expon*rrij*e_augm +! Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate angular part of the gradient. + call sc_grad_scale(sss) + endif + enddo ! j + enddo ! iint + enddo ! i + end subroutine egbv_short +!----------------------------------------------------------------------------- + subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +! +! This subroutine calculates the average interaction energy and its gradient +! in the virtual-bond vectors between non-adjacent peptide groups, based on +! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. +! The potential depends both on the distance of peptide-group centers and on +! the orientation of the CA-CA virtual bonds. +! +! implicit real*8 (a-h,o-z) + + use comm_locel +#ifdef MPI + include 'mpif.h' +#endif +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VECTORS' +! include 'COMMON.FFIELD' +! include 'COMMON.TIME1' + real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg + real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg + real(kind=8),dimension(2,2) :: acipa !el,a_temp +!el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 + real(kind=8),dimension(4) :: muij +!el integer :: num_conti,j1,j2 +!el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& +!el dz_normi,xmedi,ymedi,zmedi +!el common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,& +!el dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& +!el num_conti,j1,j2 +! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + real(kind=8) :: scal_el=1.0d0 +#else + real(kind=8) :: scal_el=0.5d0 +#endif +! 12/13/98 +! 13-go grudnia roku pamietnego... + real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,& + 0.0d0,1.0d0,0.0d0,& + 0.0d0,0.0d0,1.0d0/),shape(unmat)) +!el local variables + integer :: i,j,k + real(kind=8) :: fac + real(kind=8) :: dxj,dyj,dzj + real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4 + +! allocate(num_cont_hb(nres)) !(maxres) +!d write(iout,*) 'In EELEC' +!d do i=1,nloctyp +!d write(iout,*) 'Type',i +!d write(iout,*) 'B1',B1(:,i) +!d write(iout,*) 'B2',B2(:,i) +!d write(iout,*) 'CC',CC(:,:,i) +!d write(iout,*) 'DD',DD(:,:,i) +!d write(iout,*) 'EE',EE(:,:,i) +!d enddo +!d call check_vecgrad +!d stop + if (icheckgrad.eq.1) then + do i=1,nres-1 + fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) + do k=1,3 + dc_norm(k,i)=dc(k,i)*fac + enddo +! write (iout,*) 'i',i,' fac',fac + enddo + endif + if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & + .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. & + wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then +! call vec_and_deriv +#ifdef TIMING + time01=MPI_Wtime() +#endif + call set_matrices +#ifdef TIMING + time_mat=time_mat+MPI_Wtime()-time01 +#endif + endif +!d do i=1,nres-1 +!d write (iout,*) 'i=',i +!d do k=1,3 +!d write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) +!d enddo +!d do k=1,3 +!d write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') +!d & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) +!d enddo +!d enddo + t_eelecij=0.0d0 + ees=0.0D0 + evdw1=0.0D0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 +!el ind=0 + do i=1,nres + num_cont_hb(i)=0 + enddo +!d print '(a)','Enter EELEC' +!d write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e +! if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres) +! if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres) + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + enddo +! +! +! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms +! +! Loop over i,i+2 and i,i+3 pairs of the peptide groups +! + do i=iturn3_start,iturn3_end + if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 & + .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 + call eelecij_scale(i,i+2,ees,evdw1,eel_loc) + if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) + num_cont_hb(i)=num_conti + enddo + do i=iturn4_start,iturn4_end + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 & + .or. itype(i+3).eq.ntyp1 & + .or. itype(i+4).eq.ntyp1) cycle + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=num_cont_hb(i) + call eelecij_scale(i,i+3,ees,evdw1,eel_loc) + if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & + call eturn4(i,eello_turn4) + num_cont_hb(i)=num_conti + enddo ! i +! +! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 +! + do i=iatel_s,iatel_e + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi +! write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) + num_conti=num_cont_hb(i) + do j=ielstart(i),ielend(i) + if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle + call eelecij_scale(i,j,ees,evdw1,eel_loc) + enddo ! j + num_cont_hb(i)=num_conti + enddo ! i +! write (iout,*) "Number of loop steps in EELEC:",ind +!d do i=1,nres +!d write (iout,'(i3,3f10.5,5x,3f10.5)') +!d & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) +!d enddo +! 12/7/99 Adam eello_turn3 will be considered as a separate energy term +!cc eel_loc=eel_loc+eello_turn3 +!d print *,"Processor",fg_rank," t_eelecij",t_eelecij + return + end subroutine eelec_scale +!----------------------------------------------------------------------------- + subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) +! implicit real*8 (a-h,o-z) + + use comm_locel +! include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VECTORS' +! include 'COMMON.FFIELD' +! include 'COMMON.TIME1' + real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg + real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg + real(kind=8),dimension(2,2) :: acipa !el,a_temp +!el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 + real(kind=8),dimension(4) :: muij +!el integer :: num_conti,j1,j2 +!el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& +!el dz_normi,xmedi,ymedi,zmedi +!el common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,& +!el dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& +!el num_conti,j1,j2 +! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + real(kind=8) :: scal_el=1.0d0 +#else + real(kind=8) :: scal_el=0.5d0 +#endif +! 12/13/98 +! 13-go grudnia roku pamietnego... + real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,& + 0.0d0,1.0d0,0.0d0,& + 0.0d0,0.0d0,1.0d0/),shape(unmat)) +!el local variables + integer :: i,j,k,l,iteli,itelj,kkk,kkll,m + real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj + real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac + real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij + real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont + real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp + real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,& + dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,& + ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,& + wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,& + ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,& + ecosam,ecosbm,ecosgm,ghalf,time00 +! integer :: maxconts +! maxconts = nres/4 +! allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) +! allocate(facont_hb(maxconts,nres)) !(maxconts,maxres) +! allocate(ees0p(maxconts,nres)) !(maxconts,maxres) +! allocate(ees0m(maxconts,nres)) !(maxconts,maxres) +! allocate(d_cont(maxconts,nres)) !(maxconts,maxres) +! allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres) + +! allocate(a_chuj(2,2,maxconts,nres)) !(2,2,maxconts,maxres) +! allocate(a_chuj_der(2,2,3,5,maxconts,nres)) !(2,2,3,5,maxconts,maxres) + +#ifdef MPI + time00=MPI_Wtime() +#endif +!d write (iout,*) "eelecij",i,j +!el ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) + ael6i=ael6(iteli,itelj) + ael3i=ael3(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + rmij=1.0D0/rij +! For extracting the short-range part of Evdwpp + sss=sscale(rij/rpp(iteli,itelj)) + + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj + cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij + cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij + fac=cosa-3.0D0*cosb*cosg + ev1=aaa*r6ij*r6ij +! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + eesij=el1+el2 +! 12/26/95 - for the evaluation of multi-body H-bonding interactions + ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + ees=ees+eesij + evdw1=evdw1+evdwij*(1.0d0-sss) +!d write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') +!d & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, +!d & 1.0D0/dsqrt(rrmij),evdwij,eesij, +!d & xmedi,ymedi,zmedi,xj,yj,zj + + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss + write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij + endif + +! +! Calculate contributions to the Cartesian gradient. +! +#ifdef SPLITELE + facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) + facel=-3*rrmij*(el1+eesij) + fac1=fac + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij +! +! Radial derivatives. First process both termini of the fragment (i,j) +! + ggg(1)=facel*xj + ggg(2)=facel*yj + ggg(3)=facel*zj +! do k=1,3 +! ghalf=0.5D0*ggg(k) +! gelc(k,i)=gelc(k,i)+ghalf +! gelc(k,j)=gelc(k,j)+ghalf +! enddo +! 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo +! +! Loop over residues i+1 thru j-1. +! +!grad do k=i+1,j-1 +!grad do l=1,3 +!grad gelc(l,k)=gelc(l,k)+ggg(l) +!grad enddo +!grad enddo + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj +! do k=1,3 +! ghalf=0.5D0*ggg(k) +! gvdwpp(k,i)=gvdwpp(k,i)+ghalf +! gvdwpp(k,j)=gvdwpp(k,j)+ghalf +! enddo +! 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo +! +! Loop over residues i+1 thru j-1. +! +!grad do k=i+1,j-1 +!grad do l=1,3 +!grad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) +!grad enddo +!grad enddo +#else + facvdw=ev1+evdwij*(1.0d0-sss) + facel=el1+eesij + fac1=fac + fac=-3*rrmij*(facvdw+facvdw+facel) + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij +! +! Radial derivatives. First process both termini of the fragment (i,j) +! + ggg(1)=fac*xj + ggg(2)=fac*yj + ggg(3)=fac*zj +! do k=1,3 +! ghalf=0.5D0*ggg(k) +! gelc(k,i)=gelc(k,i)+ghalf +! gelc(k,j)=gelc(k,j)+ghalf +! enddo +! 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gelc_long(k,j)=gelc(k,j)+ggg(k) + gelc_long(k,i)=gelc(k,i)-ggg(k) + enddo +! +! Loop over residues i+1 thru j-1. +! +!grad do k=i+1,j-1 +!grad do l=1,3 +!grad gelc(l,k)=gelc(l,k)+ggg(l) +!grad enddo +!grad enddo +! 9/28/08 AL Gradient compotents will be summed only at the end + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo +#endif +! +! Angular part +! + ecosa=2.0D0*fac3*fac1+fac4 + fac4=-3.0D0*fac4 + fac3=-6.0D0*fac3 + ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) + ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo +!d print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), +!d & (dcosg(k),k=1,3) + do k=1,3 + ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) + enddo +! do k=1,3 +! ghalf=0.5D0*ggg(k) +! gelc(k,i)=gelc(k,i)+ghalf +! & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) +! & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) +! gelc(k,j)=gelc(k,j)+ghalf +! & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) +! & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) +! enddo +!grad do k=i+1,j-1 +!grad do l=1,3 +!grad gelc(l,k)=gelc(l,k)+ggg(l) +!grad enddo +!grad enddo + do k=1,3 + gelc(k,i)=gelc(k,i) & + +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gelc(k,j)=gelc(k,j) & + +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo + IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & + .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 & + .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +! +! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction +! energy of a peptide unit is assumed in the form of a second-order +! Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. +! Macromolecules, 1974, 7, 797-806 for definition). This correlation terms +! are computed for EVERY pair of non-contiguous peptide groups. +! + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + kkk=0 + do k=1,2 + do l=1,2 + kkk=kkk+1 + muij(kkk)=mu(k,i)*mu(l,j) + enddo + enddo +!d write (iout,*) 'EELEC: i',i,' j',j +!d write (iout,*) 'j',j,' j1',j1,' j2',j2 +!d write(iout,*) 'muij',muij + ury=scalar(uy(1,i),erij) + urz=scalar(uz(1,i),erij) + vry=scalar(uy(1,j),erij) + vrz=scalar(uz(1,j),erij) + a22=scalar(uy(1,i),uy(1,j))-3*ury*vry + a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz + a32=scalar(uz(1,i),uy(1,j))-3*urz*vry + a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz + fac=dsqrt(-ael6i)*r3ij + a22=a22*fac + a23=a23*fac + a32=a32*fac + a33=a33*fac +!d write (iout,'(4i5,4f10.5)') +!d & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 +!d write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij +!d write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), +!d & uy(:,j),uz(:,j) +!d write (iout,'(4f10.5)') +!d & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), +!d & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) +!d write (iout,'(4f10.5)') ury,urz,vry,vrz +!d write (iout,'(9f10.5/)') +!d & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij +! Derivatives of the elements of A in virtual-bond vectors + call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) + do k=1,3 + uryg(k,1)=scalar(erder(1,k),uy(1,i)) + uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) + uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) + urzg(k,1)=scalar(erder(1,k),uz(1,i)) + urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) + urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) + vryg(k,1)=scalar(erder(1,k),uy(1,j)) + vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) + vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) + vrzg(k,1)=scalar(erder(1,k),uz(1,j)) + vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) + vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) + enddo +! Compute radial contributions to the gradient + facr=-3.0d0*rrmij + a22der=a22*facr + a23der=a23*facr + a32der=a32*facr + a33der=a33*facr + agg(1,1)=a22der*xj + agg(2,1)=a22der*yj + agg(3,1)=a22der*zj + agg(1,2)=a23der*xj + agg(2,2)=a23der*yj + agg(3,2)=a23der*zj + agg(1,3)=a32der*xj + agg(2,3)=a32der*yj + agg(3,3)=a32der*zj + agg(1,4)=a33der*xj + agg(2,4)=a33der*yj + agg(3,4)=a33der*zj +! Add the contributions coming from er + fac3=-3.0d0*fac + do k=1,3 + agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) + agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) + agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) + agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) + enddo + do k=1,3 +! Derivatives in DC(i) +!grad ghalf1=0.5d0*agg(k,1) +!grad ghalf2=0.5d0*agg(k,2) +!grad ghalf3=0.5d0*agg(k,3) +!grad ghalf4=0.5d0*agg(k,4) + aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) & + -3.0d0*uryg(k,2)*vry)!+ghalf1 + aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) & + -3.0d0*uryg(k,2)*vrz)!+ghalf2 + aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) & + -3.0d0*urzg(k,2)*vry)!+ghalf3 + aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) & + -3.0d0*urzg(k,2)*vrz)!+ghalf4 +! Derivatives in DC(i+1) + aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) & + -3.0d0*uryg(k,3)*vry)!+agg(k,1) + aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) & + -3.0d0*uryg(k,3)*vrz)!+agg(k,2) + aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) & + -3.0d0*urzg(k,3)*vry)!+agg(k,3) + aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) & + -3.0d0*urzg(k,3)*vrz)!+agg(k,4) +! Derivatives in DC(j) + aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) & + -3.0d0*vryg(k,2)*ury)!+ghalf1 + aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) & + -3.0d0*vrzg(k,2)*ury)!+ghalf2 + aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) & + -3.0d0*vryg(k,2)*urz)!+ghalf3 + aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) & + -3.0d0*vrzg(k,2)*urz)!+ghalf4 +! Derivatives in DC(j+1) or DC(nres-1) + aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) & + -3.0d0*vryg(k,3)*ury) + aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) & + -3.0d0*vrzg(k,3)*ury) + aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) & + -3.0d0*vryg(k,3)*urz) + aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) & + -3.0d0*vrzg(k,3)*urz) +!grad if (j.eq.nres-1 .and. i.lt.j-2) then +!grad do l=1,4 +!grad aggj1(k,l)=aggj1(k,l)+agg(k,l) +!grad enddo +!grad endif + enddo + acipa(1,1)=a22 + acipa(1,2)=a23 + acipa(2,1)=a32 + acipa(2,2)=a33 + a22=-a22 + a23=-a23 + do l=1,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + if (j.lt.nres-1) then + a22=-a22 + a32=-a32 + do l=1,3,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + else + a22=-a22 + a23=-a23 + a32=-a32 + a33=-a33 + do l=1,4 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + endif + ENDIF ! WCORR + IF (wel_loc.gt.0.0d0) THEN +! Contribution to the local-electrostatic energy coming from the i-j pair + eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) & + +a33*muij(4) +! write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & + 'eelloc',i,j,eel_loc_ij +! write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d + + eel_loc=eel_loc+eel_loc_ij +! Partial derivatives in virtual-bond dihedral angles gamma + if (i.gt.1) & + gel_loc_loc(i-1)=gel_loc_loc(i-1)+ & + a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) & + +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) + gel_loc_loc(j-1)=gel_loc_loc(j-1)+ & + a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) & + +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) +! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + do l=1,3 + ggg(l)=agg(l,1)*muij(1)+ & + agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) + gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) + gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) +!grad ghalf=0.5d0*ggg(l) +!grad gel_loc(l,i)=gel_loc(l,i)+ghalf +!grad gel_loc(l,j)=gel_loc(l,j)+ghalf + enddo +!grad do k=i+1,j2 +!grad do l=1,3 +!grad gel_loc(l,k)=gel_loc(l,k)+ggg(l) +!grad enddo +!grad enddo +! Remaining derivatives of eello + do l=1,3 + gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ & + aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) + gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ & + aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) + gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ & + aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) + gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ & + aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) + enddo + ENDIF +! Change 12/26/95 to calculate four-body contributions to H-bonding energy +! if (j.gt.i+1 .and. num_conti.le.maxconts) then + if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & + .and. num_conti.le.maxconts) then +! write (iout,*) i,j," entered corr" +! +! Calculate the contact function. The ith column of the array JCONT will +! contain the numbers of atoms that make contacts with the atom I (of numbers +! greater than I). The arrays FACONT and GACONT will contain the values of +! the contact function and its derivative. +! r0ij=1.02D0*rpp(iteli,itelj) +! r0ij=1.11D0*rpp(iteli,itelj) + r0ij=2.20D0*rpp(iteli,itelj) +! r0ij=1.55D0*rpp(iteli,itelj) + call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) +!elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts + if (fcont.gt.0.0D0) then + num_conti=num_conti+1 + if (num_conti.gt.maxconts) then +!elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts + write (iout,*) 'WARNING - max. # of contacts exceeded;',& + ' will skip next contacts for this conf.',num_conti + else + jcont_hb(num_conti,i)=j +!d write (iout,*) "i",i," j",j," num_conti",num_conti, +!d & " jcont_hb",jcont_hb(num_conti,i) + IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. & + wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el +! terms. + d_cont(num_conti,i)=rij +!d write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij +! --- Electrostatic-interaction matrix --- + a_chuj(1,1,num_conti,i)=a22 + a_chuj(1,2,num_conti,i)=a23 + a_chuj(2,1,num_conti,i)=a32 + a_chuj(2,2,num_conti,i)=a33 +! --- Gradient of rij + do kkk=1,3 + grij_hb_cont(kkk,num_conti,i)=erij(kkk) + enddo + kkll=0 + do k=1,2 + do l=1,2 + kkll=kkll+1 + do m=1,3 + a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) + a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) + a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) + a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) + a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) + enddo + enddo + enddo + ENDIF + IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN +! Calculate contact energies + cosa4=4.0D0*cosa + wij=cosa-3.0D0*cosb*cosg + cosbg1=cosb+cosg + cosbg2=cosb-cosg +! fac3=dsqrt(-ael6i)/r0ij**3 + fac3=dsqrt(-ael6i)*r3ij +! ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) + ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 + if (ees0tmp.gt.0) then + ees0pij=dsqrt(ees0tmp) + else + ees0pij=0 + endif +! ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) + ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 + if (ees0tmp.gt.0) then + ees0mij=dsqrt(ees0tmp) + else + ees0mij=0 + endif +! ees0mij=0.0D0 + ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) +! Diagnostics. Comment out or remove after debugging! +! ees0p(num_conti,i)=0.5D0*fac3*ees0pij +! ees0m(num_conti,i)=0.5D0*fac3*ees0mij +! ees0m(num_conti,i)=0.0D0 +! End diagnostics. +! write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, +! & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont +! Angular derivatives of the contact function + ees0pij1=fac3/ees0pij + ees0mij1=fac3/ees0mij + fac3p=-3.0D0*fac3*rrmij + ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) + ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) +! ees0mij1=0.0D0 + ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) + ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) + ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) + ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) + ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) + ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) + ecosap=ecosa1+ecosa2 + ecosbp=ecosb1+ecosb2 + ecosgp=ecosg1+ecosg2 + ecosam=ecosa1-ecosa2 + ecosbm=ecosb1-ecosb2 + ecosgm=ecosg1-ecosg2 +! Diagnostics +! ecosap=ecosa1 +! ecosbp=ecosb1 +! ecosgp=ecosg1 +! ecosam=0.0D0 +! ecosbm=0.0D0 +! ecosgm=0.0D0 +! End diagnostics + facont_hb(num_conti,i)=fcont + fprimcont=fprimcont/rij +!d facont_hb(num_conti,i)=1.0D0 +! Following line is for diagnostics. +!d fprimcont=0.0D0 + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo + do k=1,3 + gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) + gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) + enddo + gggp(1)=gggp(1)+ees0pijp*xj + gggp(2)=gggp(2)+ees0pijp*yj + gggp(3)=gggp(3)+ees0pijp*zj + gggm(1)=gggm(1)+ees0mijp*xj + gggm(2)=gggm(2)+ees0mijp*yj + gggm(3)=gggm(3)+ees0mijp*zj +! Derivatives due to the contact function + gacont_hbr(1,num_conti,i)=fprimcont*xj + gacont_hbr(2,num_conti,i)=fprimcont*yj + gacont_hbr(3,num_conti,i)=fprimcont*zj + do k=1,3 +! +! 10/24/08 cgrad and ! comments indicate the parts of the code removed +! following the change of gradient-summation algorithm. +! +!grad ghalfp=0.5D0*gggp(k) +!grad ghalfm=0.5D0*gggm(k) + gacontp_hb1(k,num_conti,i)= & !ghalfp + +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontp_hb2(k,num_conti,i)= & !ghalfp + +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontp_hb3(k,num_conti,i)=gggp(k) + gacontm_hb1(k,num_conti,i)= &!ghalfm + +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontm_hb2(k,num_conti,i)= & !ghalfm + +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontm_hb3(k,num_conti,i)=gggm(k) + enddo + ENDIF ! wcorr + endif ! num_conti.le.maxconts + endif ! fcont.gt.0 + endif ! j.gt.i+1 + if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then + do k=1,4 + do l=1,3 + ghalf=0.5d0*agg(l,k) + aggi(l,k)=aggi(l,k)+ghalf + aggi1(l,k)=aggi1(l,k)+agg(l,k) + aggj(l,k)=aggj(l,k)+ghalf + enddo + enddo + if (j.eq.nres-1 .and. i.lt.j-2) then + do k=1,4 + do l=1,3 + aggj1(l,k)=aggj1(l,k)+agg(l,k) + enddo + enddo + endif + endif +! t_eelecij=t_eelecij+MPI_Wtime()-time00 + return + end subroutine eelecij_scale +!----------------------------------------------------------------------------- + subroutine evdwpp_short(evdw1) +! +! Compute Evdwpp +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' +! include 'COMMON.VECTORS' +! include 'COMMON.FFIELD' + real(kind=8),dimension(3) :: ggg +! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + real(kind=8) :: scal_el=1.0d0 +#else + real(kind=8) :: scal_el=0.5d0 +#endif +!el local variables + integer :: i,j,k,iteli,itelj,num_conti + real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb + real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,& + dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& + dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw + + evdw1=0.0D0 +! write (iout,*) "iatel_s_vdw",iatel_s_vdw, +! & " iatel_e_vdw",iatel_e_vdw + call flush(iout) + do i=iatel_s_vdw,iatel_e_vdw + if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 +! write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), +! & ' ielend',ielend_vdw(i) + call flush(iout) + do j=ielstart_vdw(i),ielend_vdw(i) + if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle +!el ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + sss=sscale(rij/rpp(iteli,itelj)) + if (sss.gt.0.0d0) then + rmij=1.0D0/rij + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + ev1=aaa*r6ij*r6ij +! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + evdwij=ev1+ev2 + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss + endif + evdw1=evdw1+evdwij*sss +! +! Calculate contributions to the Cartesian gradient. +! + facvdw=-6*rrmij*(ev1+evdwij)*sss + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo + endif + enddo ! j + enddo ! i + return + end subroutine evdwpp_short +!----------------------------------------------------------------------------- + subroutine escp_long(evdw2,evdw2_14) +! +! This subroutine calculates the excluded-volume interaction energy between +! peptide-group centers and side chains and its gradient in virtual-bond and +! side-chain vectors. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' + real(kind=8),dimension(3) :: ggg +!el local variables + integer :: i,iint,j,k,iteli,itypj + real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2 + real(kind=8) :: evdw2,evdw2_14,evdwij + evdw2=0.0D0 + evdw2_14=0.0d0 +!d print '(a)','Enter ESCP' +!d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! Uncomment following three lines for SC-p interactions +! xj=c(1,nres+j)-xi +! yj=c(2,nres+j)-yi +! zj=c(3,nres+j)-zi +! Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) + + if (sss.lt.1.0d0) then + + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij*(1.0d0-sss) + if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & + 'evdw2',i,j,sss,evdwij +! +! Calculate contributions to the gradient in the virtual-bond and SC vectors. +! + fac=-(evdwij+e1)*rrij*(1.0d0-sss) + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +! Uncomment following three lines for SC-p interactions +! do k=1,3 +! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +! enddo +! Uncomment following line for SC-p interactions +! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + endif + enddo + + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +!****************************************************************************** +! +! N O T E !!! +! +! To save time the factor EXPON has been extracted from ALL components +! of GVDWC and GRADX. Remember to multiply them by this factor before further +! use! +! +!****************************************************************************** + return + end subroutine escp_long +!----------------------------------------------------------------------------- + subroutine escp_short(evdw2,evdw2_14) +! +! This subroutine calculates the excluded-volume interaction energy between +! peptide-group centers and side chains and its gradient in virtual-bond and +! side-chain vectors. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' + real(kind=8),dimension(3) :: ggg +!el local variables + integer :: i,iint,j,k,iteli,itypj + real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2 + real(kind=8) :: evdw2,evdw2_14,evdwij + evdw2=0.0D0 + evdw2_14=0.0d0 +!d print '(a)','Enter ESCP' +!d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) + if (itypj.eq.ntyp1) cycle +! Uncomment following three lines for SC-p interactions +! xj=c(1,nres+j)-xi +! yj=c(2,nres+j)-yi +! zj=c(3,nres+j)-zi +! Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) + + if (sss.gt.0.0d0) then + + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+(e1+e2)*sss + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij*sss + if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & + 'evdw2',i,j,sss,evdwij +! +! Calculate contributions to the gradient in the virtual-bond and SC vectors. +! + fac=-(evdwij+e1)*rrij*sss + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +! Uncomment following three lines for SC-p interactions +! do k=1,3 +! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +! enddo +! Uncomment following line for SC-p interactions +! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + endif + enddo + + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +!****************************************************************************** +! +! N O T E !!! +! +! To save time the factor EXPON has been extracted from ALL components +! of GVDWC and GRADX. Remember to multiply them by this factor before further +! use! +! +!****************************************************************************** + return + end subroutine escp_short +!----------------------------------------------------------------------------- +! energy_p_new-sep_barrier.F +!----------------------------------------------------------------------------- + subroutine sc_grad_scale(scalfac) +! implicit real*8 (a-h,o-z) + use calc_data +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.CALC' +! include 'COMMON.IOUNITS' + real(kind=8),dimension(3) :: dcosom1,dcosom2 + real(kind=8) :: scalfac +!el local variables +! integer :: i,j,k,l + + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & + -2.0D0*alf12*eps3der+sigder*sigsq_om12 +! diagnostics only +! eom1=0.0d0 +! eom2=0.0d0 +! eom12=evdwij*eps1_om12 +! end diagnostics +! write (iout,*) "eps2der",eps2der," eps3der",eps3der, +! & " sigder",sigder +! write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 +! write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + do k=1,3 + gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac + enddo +! write (iout,*) "gg",(gg(k),k=1,3) + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) & + +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & + +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac + gvdwx(k,j)=gvdwx(k,j)+gg(k) & + +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac +! write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) +! & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv +! write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) +! & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +! +! Calculate the components of the gradient in DC and X +! + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + return + end subroutine sc_grad_scale +!----------------------------------------------------------------------------- +! energy_split-sep.F +!----------------------------------------------------------------------------- + subroutine etotal_long(energia) +! +! Compute the long-range slow-varying contributions to the energy +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use MD_data, only: totT +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw +#endif +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.MD' + real(kind=8),dimension(0:n_ene) :: energia +!el local variables + integer :: i,n_corr,n_corr1,ierror,ierr + real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,& + evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,& + ecorr,ecorr5,ecorr6,eturn6,time00 +! write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot +!elwrite(iout,*)"in etotal long" + + if (modecalc.eq.12.or.modecalc.eq.14) then +#ifdef MPI +! if (fg_rank.eq.0) call int_from_cart1(.false.) +#else + call int_from_cart1(.false.) +#endif + endif +!elwrite(iout,*)"in etotal long" + +#ifdef MPI +! write(iout,*) "ETOTAL_LONG Processor",fg_rank, +! & " absolute rank",myrank," nfgtasks",nfgtasks + call flush(iout) + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +! FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) +! write (iout,*) "Processor",myrank," BROADCAST iorder" +! call flush(iout) +! FG master sets up the WEIGHTS_ array which will be broadcast to the +! FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor +! FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene,& + MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +! FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene,& + MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + endif + call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +! call chainbuild_cart +! call int_from_cart1(.false.) + endif +! write (iout,*) 'Processor',myrank, +! & ' calling etotal_short ipot=',ipot +! call flush(iout) +! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#endif +!d print *,'nnt=',nnt,' nct=',nct +! +!elwrite(iout,*)"in etotal long" +! Compute the side-chain and electrostatic interaction energy +! + goto (101,102,103,104,105,106) ipot +! Lennard-Jones potential. + 101 call elj_long(evdw) +!d print '(a)','Exit ELJ' + goto 107 +! Lennard-Jones-Kihara potential (shifted). + 102 call eljk_long(evdw) + goto 107 +! Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp_long(evdw) + goto 107 +! Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb_long(evdw) + goto 107 +! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv_long(evdw) + goto 107 +! Soft-sphere potential + 106 call e_softsphere(evdw) +! +! Calculate electrostatic (H-bonding) energy of the main chain. +! + 107 continue + call vec_and_deriv + if (ipot.lt.6) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. & + wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & + .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & + .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. & + wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & + .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & + .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + else + ees=0 + evdw1=0 + eel_loc=0 + eello_turn3=0 + eello_turn4=0 + endif + else +! write (iout,*) "Soft-spheer ELEC potential" + call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,& + eello_turn4) + endif +! +! Calculate excluded-volume interaction energy between peptide groups +! and side chains. +! + if (ipot.lt.6) then + if(wscp.gt.0d0) then + call escp_long(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else + call escp_soft_sphere(evdw2,evdw2_14) + endif +! +! 12/1/95 Multi-body terms +! + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 & + .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +! write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, +! &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 + else + ecorr=0.0d0 + ecorr5=0.0d0 + ecorr6=0.0d0 + eturn6=0.0d0 + endif + if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +! +! If performing constraint dynamics, call the constraint energy +! after the equilibration time + if(usampl.and.totT.gt.eq_time) then + call EconstrQ + call Econstr_back + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +! +! Sum the energies +! + do i=1,n_ene + energia(i)=0.0d0 + enddo + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(20)=Uconst+Uconst_back + call sum_energy(energia,.true.) +! write (iout,*) "Exit ETOTAL_LONG" + call flush(iout) + return + end subroutine etotal_long +!----------------------------------------------------------------------------- + subroutine etotal_short(energia) +! +! Compute the short-range fast-varying contributions to the energy +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + integer :: ierror,ierr + real(kind=8),dimension(n_ene) :: weights_ + real(kind=8) :: time00 +#endif +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.DERIV' +! include 'COMMON.INTERACT' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' + real(kind=8),dimension(0:n_ene) :: energia +!el local variables + integer :: i,nres6 + real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors + real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr + nres6=6*nres + +! write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot +! call flush(iout) + if (modecalc.eq.12.or.modecalc.eq.14) then +#ifdef MPI + if (fg_rank.eq.0) call int_from_cart1(.false.) +#else + call int_from_cart1(.false.) +#endif + endif +#ifdef MPI +! write(iout,*) "ETOTAL_SHORT Processor",fg_rank, +! & " absolute rank",myrank," nfgtasks",nfgtasks +! call flush(iout) + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +! FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) +! write (iout,*) "Processor",myrank," BROADCAST iorder" +! call flush(iout) +! FG master sets up the WEIGHTS_ array which will be broadcast to the +! FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor +! FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene,& + MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +! FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene,& + MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + endif +! write (iout,*),"Processor",myrank," BROADCAST weights" + call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST c" + call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST dc" + call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST dc_norm" + call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST theta" + call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST phi" + call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST alph" + call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST omeg" + call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "Processor",myrank," BROADCAST vbld" + call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 +! write (iout,*) "Processor",myrank," BROADCAST vbld_inv" + endif +! write (iout,*) 'Processor',myrank, +! & ' calling etotal_short ipot=',ipot +! call flush(iout) +! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#endif +! call int_from_cart1(.false.) +! +! Compute the side-chain and electrostatic interaction energy +! + goto (101,102,103,104,105,106) ipot +! Lennard-Jones potential. + 101 call elj_short(evdw) +!d print '(a)','Exit ELJ' + goto 107 +! Lennard-Jones-Kihara potential (shifted). + 102 call eljk_short(evdw) + goto 107 +! Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp_short(evdw) + goto 107 +! Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb_short(evdw) + goto 107 +! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv_short(evdw) + goto 107 +! Soft-sphere potential - already dealt with in the long-range part + 106 evdw=0.0d0 +! 106 call e_softsphere_short(evdw) +! +! Calculate electrostatic (H-bonding) energy of the main chain. +! + 107 continue +! +! Calculate the short-range part of Evdwpp +! + call evdwpp_short(evdw1) +! +! Calculate the short-range part of ESCp +! + if (ipot.lt.6) then + call escp_short(evdw2,evdw2_14) + endif +! +! Calculate the bond-stretching energy +! + call ebond(estr) +! +! Calculate the disulfide-bridge and other energy and the contributions +! from other distance constraints. + call edis(ehpb) +! +! Calculate the virtual-bond-angle energy. +! + call ebend(ebe) +! +! Calculate the SC local energy. +! + call vec_and_deriv + call esc(escloc) +! +! Calculate the virtual-bond torsional energy. +! + call etor(etors,edihcnstr) +! +! 6/23/01 Calculate double-torsional energy +! + call etor_d(etors_d) +! +! 21/5/07 Calculate local sicdechain correlation energy +! + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +! +! Put energy components into an array +! + do i=1,n_ene + energia(i)=0.0d0 + enddo + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(16)=evdw1 +#else + energia(3)=evdw1 +#endif + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(17)=estr + energia(19)=edihcnstr + energia(21)=esccor +! write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" + call flush(iout) + call sum_energy(energia,.true.) +! write (iout,*) "Exit ETOTAL_SHORT" + call flush(iout) + return + end subroutine etotal_short +!----------------------------------------------------------------------------- +! gnmr1.f +!----------------------------------------------------------------------------- + real(kind=8) function gnmr1(y,ymin,ymax) +! implicit none + real(kind=8) :: y,ymin,ymax + real(kind=8) :: wykl=4.0d0 + if (y.lt.ymin) then + gnmr1=(ymin-y)**wykl/wykl + else if (y.gt.ymax) then + gnmr1=(y-ymax)**wykl/wykl + else + gnmr1=0.0d0 + endif + return + end function gnmr1 +!----------------------------------------------------------------------------- + real(kind=8) function gnmr1prim(y,ymin,ymax) +! implicit none + real(kind=8) :: y,ymin,ymax + real(kind=8) :: wykl=4.0d0 + if (y.lt.ymin) then + gnmr1prim=-(ymin-y)**(wykl-1) + else if (y.gt.ymax) then + gnmr1prim=(y-ymax)**(wykl-1) + else + gnmr1prim=0.0d0 + endif + return + end function gnmr1prim +!----------------------------------------------------------------------------- + real(kind=8) function harmonic(y,ymax) +! implicit none + real(kind=8) :: y,ymax + real(kind=8) :: wykl=2.0d0 + harmonic=(y-ymax)**wykl + return + end function harmonic +!----------------------------------------------------------------------------- + real(kind=8) function harmonicprim(y,ymax) + real(kind=8) :: y,ymin,ymax + real(kind=8) :: wykl=2.0d0 + harmonicprim=(y-ymax)*wykl + return + end function harmonicprim +!----------------------------------------------------------------------------- +! gradient_p.F +!----------------------------------------------------------------------------- + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + + use io_base, only:intout,briefout +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' + real(kind=8),external :: ufparm + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) + real(kind=8) :: f,gthetai,gphii,galphai,gomegai + integer :: n,nf,ind,ind1,i,k,j +! +! This subroutine calculates total internal coordinate gradient. +! Depending on the number of function evaluations, either whole energy +! is evaluated beforehand, Cartesian coordinates and their derivatives in +! internal coordinates are reevaluated or only the cartesian-in-internal +! coordinate derivatives are evaluated. The subroutine was designed to work +! with SUMSL. +! +! + icg=mod(nf,2)+1 + +!d print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +! write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +! write (iout,*) 'grad 30' +! +! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +! + 40 call cartder +! write (iout,*) 'grad 40' +! print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +! +! Convert the Cartesian gradient into internal-coordinate gradient. +! + ind=0 + ind1=0 + do i=1,nres-2 + gthetai=0.0D0 + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 +! ind=indmat(i,j) +! print *,'GRAD: i=',i,' jc=',j,' ind=',ind + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + enddo + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + enddo + enddo + do j=i+1,nres-1 + ind1=ind1+1 +! ind1=indmat(i,j) +! print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 + do k=1,3 + gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) + gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) + enddo + enddo + if (i.gt.1) g(i-1)=gphii + if (n.gt.nphi) g(nphi+i)=gthetai + enddo + if (n.le.nphi+ntheta) goto 10 + do i=2,nres-1 + if (itype(i).ne.10) then + galphai=0.0D0 + gomegai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ialph(i,1))=galphai + g(ialph(i,1)+nside)=gomegai + endif + enddo +! +! Add the components corresponding to local energy terms. +! + 10 continue + do i=1,nvar +!d write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +! Uncomment following three lines for diagnostics. +!d call intout +!elwrite(iout,*) "in gradient after calling intout" +!d call briefout(0,0.0d0) +!d write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end subroutine gradient +!----------------------------------------------------------------------------- + subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F + + use comm_chu +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' + integer :: n,nf +!el integer :: jjj +!el common /chuju/ jjj + real(kind=8) :: energia(0:n_ene) + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8) :: f + real(kind=8),external :: ufparm + real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) +! if (jjj.gt.0) then +! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +! endif + nfl=nf + icg=mod(nf,2)+1 +!d print *,'func',nf,nfl,icg + call var_to_geom(n,x) + call zerograd + call chainbuild +!d write (iout,*) 'ETOTAL called from FUNC' + call etotal(energia) + call sum_gradient + f=energia(0) +! if (jjj.gt.0) then +! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +! write (iout,*) 'f=',etot +! jjj=0 +! endif + return + end subroutine func +!----------------------------------------------------------------------------- + subroutine cartgrad +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use energy_data + use MD_data, only: totT +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! + integer :: i,j + +! This subrouting calculates total Cartesian coordinate gradient. +! The subroutine chainbuild_cart and energy MUST be called beforehand. +! +!el#define DEBUG +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 + call sum_gradient +#ifdef TIMING +#endif +!el write (iout,*) "After sum_gradient" +#ifdef DEBUG +!el write (iout,*) "After sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo +#endif +! If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) + gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif +!elwrite (iout,*) "After sum_gradient" +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +!elwrite (iout,*) "After sum_gradient" +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +! call checkintcartgrad +! write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),& + (gxcart(j,i),j=1,3),gloc(i,icg) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& + (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif +!el#undef DEBUG + return + end subroutine cartgrad +!----------------------------------------------------------------------------- + subroutine zerograd +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.DERIV' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.MD' +! include 'COMMON.SCCOR' +! +!el local variables + integer :: i,j,intertyp +! Initialize Cartesian-coordinate gradient +! +! if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2) +! if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2) + +! allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres)) +! allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres)) +! allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres)) +! allocate(gradcorr_long(3,nres)) +! allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres)) +! allocate(gcorr6_turn_long(3,nres)) +! allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres) + +! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres) + +! allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres)) +! allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres)) + +! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) +! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) + +! allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres) +! allocate(gscloc(3,nres)) !(3,maxres) +! if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres) + + + +! common /deriv_scloc/ +! allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres)) +! allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres)) +! allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres)) !(3,maxres) +! common /mpgrad/ +! allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres) + + + +! gradc(j,i,icg)=0.0d0 +! gradx(j,i,icg)=0.0d0 + +! allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres +!elwrite(iout,*) "icg",icg + do i=1,nres + do j=1,3 + gvdwx(j,i)=0.0D0 + gradx_scp(j,i)=0.0D0 + gvdwc(j,i)=0.0D0 + gvdwc_scp(j,i)=0.0D0 + gvdwc_scpp(j,i)=0.0d0 + gelc(j,i)=0.0D0 + gelc_long(j,i)=0.0D0 + gradb(j,i)=0.0d0 + gradbx(j,i)=0.0d0 + gvdwpp(j,i)=0.0d0 + gel_loc(j,i)=0.0d0 + gel_loc_long(j,i)=0.0d0 + ghpbc(j,i)=0.0D0 + ghpbx(j,i)=0.0D0 + gcorr3_turn(j,i)=0.0d0 + gcorr4_turn(j,i)=0.0d0 + gradcorr(j,i)=0.0d0 + gradcorr_long(j,i)=0.0d0 + gradcorr5_long(j,i)=0.0d0 + gradcorr6_long(j,i)=0.0d0 + gcorr6_turn_long(j,i)=0.0d0 + gradcorr5(j,i)=0.0d0 + gradcorr6(j,i)=0.0d0 + gcorr6_turn(j,i)=0.0d0 + gsccorc(j,i)=0.0d0 + gsccorx(j,i)=0.0d0 + gradc(j,i,icg)=0.0d0 + gradx(j,i,icg)=0.0d0 + gscloc(j,i)=0.0d0 + gsclocx(j,i)=0.0d0 + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +! +! Initialize the gradient of local energy terms. +! +! allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres) +! if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres) +! if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres) +! allocate(g_corr5_loc(nres),g_corr6_loc(nres)) !(maxvar)(maxvar=6*maxres) +! allocate(gel_loc_turn3(nres)) +! allocate(gel_loc_turn4(nres),gel_loc_turn6(nres)) !(maxvar)(maxvar=6*maxres) +! allocate(gsccor_loc(nres)) !(maxres) + + do i=1,4*nres + gloc(i,icg)=0.0D0 + enddo + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + g_corr5_loc(i)=0.0d0 + g_corr6_loc(i)=0.0d0 + gel_loc_turn3(i)=0.0d0 + gel_loc_turn4(i)=0.0d0 + gel_loc_turn6(i)=0.0d0 + gsccor_loc(i)=0.0d0 + enddo +! initialize gcart and gxcart +! allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES) + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end subroutine zerograd +!----------------------------------------------------------------------------- + real(kind=8) function fdum() + fdum=0.0D0 + return + end function fdum +!----------------------------------------------------------------------------- +! intcartderiv.F +!----------------------------------------------------------------------------- + subroutine intcartderiv +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.LOCAL' +! include 'COMMON.SCCOR' + real(kind=8) :: pi4,pi34 + real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres) + real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,& + dcosomega,dsinomega !(3,3,maxres) + real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n + + integer :: i,j,k + real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,& + fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,& + fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,& + fac17,coso_inv,fac10,fac11,fac12,fac13,fac14 + integer :: nres2 + nres2=2*nres + +!el from module energy------------- +!el allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres +!el allocate(dsintau(3,3,3,itau_start:itau_end)) +!el allocate(dtauangle(3,3,3,itau_start:itau_end)) + +!el allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres +!el allocate(dsintau(3,3,3,0:nres2)) +!el allocate(dtauangle(3,3,3,0:nres2)) +!el allocate(domicron(3,2,2,0:nres2)) +!el allocate(dcosomicron(3,2,2,0:nres2)) + + + +#if defined(MPI) && defined(PARINTDER) + if (nfgtasks.gt.1 .and. me.eq.king) & + call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + pi4 = 0.5d0*pipol + pi34 = 3*pi4 + +! allocate(dtheta(3,2,nres)) !(3,2,maxres) +! allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres) + +! write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end + do i=1,nres + do j=1,3 + dtheta(j,1,i)=0.0d0 + dtheta(j,2,i)=0.0d0 + dphi(j,1,i)=0.0d0 + dphi(j,2,i)=0.0d0 + dphi(j,3,i)=0.0d0 + enddo + enddo +! Derivatives of theta's +#if defined(MPI) && defined(PARINTDER) +! We need dtheta(:,:,i-1) to compute dphi(:,:,i) + do i=max0(ithet_start-1,3),ithet_end +#else + do i=3,nres +#endif + cost=dcos(theta(i)) + sint=sqrt(1-cost*cost) + do j=1,3 + dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/& + vbld(i-1) + if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint + dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/& + vbld(i) + if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint + enddo + enddo +#if defined(MPI) && defined(PARINTDER) +! We need dtheta(:,:,i-1) to compute dphi(:,:,i) + do i=max0(ithet_start-1,3),ithet_end +#else + do i=3,nres +#endif + if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then + cost1=dcos(omicron(1,i)) + sint1=sqrt(1-cost1*cost1) + cost2=dcos(omicron(2,i)) + sint2=sqrt(1-cost2*cost2) + do j=1,3 +!C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1) + dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ & + cost1*dc_norm(j,i-2))/ & + vbld(i-1) + domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i) + dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) & + +cost1*(dc_norm(j,i-1+nres)))/ & + vbld(i-1+nres) + domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i) +!C Calculate derivative over second omicron Sci-1,Cai-1 Cai +!C Looks messy but better than if in loop + dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) & + +cost2*dc_norm(j,i-1))/ & + vbld(i) + domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i) + dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) & + +cost2*(-dc_norm(j,i-1+nres)))/ & + vbld(i-1+nres) +! write(iout,*) "vbld", i,itype(i),vbld(i-1+nres) + domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i) + enddo + endif + enddo +!elwrite(iout,*) "after vbld write" +! Derivatives of phi: +! If phi is 0 or 180 degrees, then the formulas +! have to be derived by power series expansion of the +! conventional formulas around 0 and 180. +#ifdef PARINTDER + do i=iphi1_start,iphi1_end +#else + do i=4,nres +#endif +! if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle +! the conventional case + sint=dsin(theta(i)) + sint1=dsin(theta(i-1)) + sing=dsin(phi(i)) + cost=dcos(theta(i)) + cost1=dcos(theta(i-1)) + cosg=dcos(phi(i)) + scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +! Obtaining the gamma derivatives from sine derivative + if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. & + phi(i).gt.pi34.and.phi(i).le.pi.or. & + phi(i).gt.-pi.and.phi(i).le.-pi34) then + call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then + dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) & + -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) + dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) + dsinphi(j,2,i)= & + -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) & + -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) + dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) + dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) & + +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) +! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) + endif +! Bug fixed 3/24/05 (AL) + enddo +! Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then + dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* & + dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* & + dc_norm(j,i-3))/vbld(i-2) + dphi(j,1,i)=-1/sing*dcosphi(j,1,i) + dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* & + dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* & + dcostheta(j,1,i) + dphi(j,2,i)=-1/sing*dcosphi(j,2,i) + dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* & + dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* & + dc_norm(j,i-1))/vbld(i) + dphi(j,3,i)=-1/sing*dcosphi(j,3,i) + endif + enddo + endif + enddo +!alculate derivative of Tauangle +#ifdef PARINTDER + do i=itau_start,itau_end +#else + do i=3,nres +!elwrite(iout,*) " vecpr",i,nres +#endif + if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle +! if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or. +! & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle +!c dtauangle(j,intertyp,dervityp,residue number) +!c INTERTYP=1 SC...Ca...Ca..Ca +! the conventional case + sint=dsin(theta(i)) + sint1=dsin(omicron(2,i-1)) + sing=dsin(tauangle(1,i)) + cost=dcos(theta(i)) + cost1=dcos(omicron(2,i-1)) + cosg=dcos(tauangle(1,i)) +!elwrite(iout,*) " vecpr5",i,nres + do j=1,3 +!elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres +!elwrite(iout,*) " vecpr5",dc_norm2(1,1) + dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) +! write(iout,*) dc_norm2(j,i-2+nres),"dcnorm" + enddo + scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +! write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4 +! Obtaining the gamma derivatives from sine derivative + if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. & + tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. & + tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then + call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) & + -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) & + *vbld_inv(i-2+nres) + dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i) + dsintau(j,1,2,i)= & + -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) & + -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) +! write(iout,*) "dsintau", dsintau(j,1,2,i) + dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i) +! Bug fixed 3/24/05 (AL) + dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) & + +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) +! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i) + enddo +! Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* & + dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* & + (dc_norm2(j,i-2+nres)))/vbld(i-2+nres) + dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i) + dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* & + dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* & + dcostheta(j,1,i) + dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i) + dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* & + dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* & + dc_norm(j,i-1))/vbld(i) + dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i) +! write (iout,*) "else",i + enddo + endif +! do k=1,3 +! write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3) +! enddo + enddo +!C Second case Ca...Ca...Ca...SC +#ifdef PARINTDER + do i=itau_start,itau_end +#else + do i=4,nres +#endif + if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. & + (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle +! the conventional case + sint=dsin(omicron(1,i)) + sint1=dsin(theta(i-1)) + sing=dsin(tauangle(2,i)) + cost=dcos(omicron(1,i)) + cost1=dcos(theta(i-1)) + cosg=dcos(tauangle(2,i)) +! do j=1,3 +! dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) +! enddo + scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +! Obtaining the gamma derivatives from sine derivative + if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. & + tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. & + tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then + call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) & + +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2) +! write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1), +! &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)" + dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i) + dsintau(j,2,2,i)= & + -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) & + -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) +! write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1), +! & sing*ctgt*domicron(j,1,2,i), +! & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) + dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i) +! Bug fixed 3/24/05 (AL) + dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) & + +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres) +! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i) + enddo +! Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* & + dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* & + dc_norm(j,i-3))/vbld(i-2) + dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i) + dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* & + dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* & + dcosomicron(j,1,1,i) + dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i) + dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* & + dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* & + dc_norm(j,i-1+nres))/vbld(i-1+nres) + dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i) +! write(iout,*) i,j,"else", dtauangle(j,2,3,i) + enddo + endif + enddo + +!CC third case SC...Ca...Ca...SC +#ifdef PARINTDER + + do i=itau_start,itau_end +#else + do i=3,nres +#endif +! the conventional case + if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. & + (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle + sint=dsin(omicron(1,i)) + sint1=dsin(omicron(2,i-1)) + sing=dsin(tauangle(3,i)) + cost=dcos(omicron(1,i)) + cost1=dcos(omicron(2,i-1)) + cosg=dcos(tauangle(3,i)) + do j=1,3 + dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) +! dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) + enddo + scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +! Obtaining the gamma derivatives from sine derivative + if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. & + tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. & + tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then + call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) & + -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) & + *vbld_inv(i-2+nres) + dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i) + dsintau(j,3,2,i)= & + -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) & + -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) + dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i) +! Bug fixed 3/24/05 (AL) + dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) & + +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) & + *vbld_inv(i-1+nres) +! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i) + enddo +! Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* & + dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* & + dc_norm2(j,i-2+nres))/vbld(i-2+nres) + dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i) + dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* & + dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* & + dcosomicron(j,1,1,i) + dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i) + dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* & + dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* & + dc_norm(j,i-1+nres))/vbld(i-1+nres) + dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i) +! write(iout,*) "else",i + enddo + endif + enddo + +#ifdef CRYST_SC +! Derivatives of side-chain angles alpha and omega +#if defined(MPI) && defined(PARINTDER) + do i=ibond_start,ibond_end +#else + do i=2,nres-1 +#endif + if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then + fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) + fac6=fac5/vbld(i) + fac7=fac5*fac5 + fac8=fac5/vbld(i+1) + fac9=fac5/vbld(i+nres) + scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* & + (scalar(dC_norm(1,i),dC_norm(1,i+nres)) & + -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) + sina=sqrt(1-cosa*cosa) + sino=dsin(omeg(i)) +! write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino + do j=1,3 + dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- & + dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) + dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) + dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- & + scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) + dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) + dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- & + dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ & + vbld(i+nres)) + dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) + enddo +! obtaining the derivatives of omega from sines + if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. & + omeg(i).gt.pi34.and.omeg(i).le.pi.or. & + omeg(i).gt.-pi.and.omeg(i).le.-pi34) then + fac15=dcos(theta(i+1))/(dsin(theta(i+1))* & + dsin(theta(i+1))) + fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) + fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) + call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) + call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) + call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) + coso_inv=1.0d0/dcos(omeg(i)) + do j=1,3 + dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) & + +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- & + (sino*dc_norm(j,i-1))/vbld(i) + domega(j,1,i)=coso_inv*dsinomega(j,1,i) + dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) & + +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) & + -sino*dc_norm(j,i)/vbld(i+1) + domega(j,2,i)=coso_inv*dsinomega(j,2,i) + dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- & + fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ & + vbld(i+nres) + domega(j,3,i)=coso_inv*dsinomega(j,3,i) + enddo + else +! obtaining the derivatives of omega from cosines + fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) + fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) + fac12=fac10*sina + fac13=fac12*fac12 + fac14=sina*sina + do j=1,3 + dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* & + dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ & + (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* & + fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 + domega(j,1,i)=-1/sino*dcosomega(j,1,i) + dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* & + dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* & + dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ & + (scala2-fac11*cosa)*(0.25d0*sina/fac10* & + dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13 + domega(j,2,i)=-1/sino*dcosomega(j,2,i) + dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- & + scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ & + (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 + domega(j,3,i)=-1/sino*dcosomega(j,3,i) + enddo + endif + else + do j=1,3 + do k=1,3 + dalpha(k,j,i)=0.0d0 + domega(k,j,i)=0.0d0 + enddo + enddo + endif + enddo +#endif +#if defined(MPI) && defined(PARINTDER) + if (nfgtasks.gt.1) then +#ifdef DEBUG +!d write (iout,*) "Gather dtheta" +!d call flush(iout) + write (iout,*) "dtheta before gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) + enddo +#endif + call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),& + MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,& + king,FG_COMM,IERROR) +#ifdef DEBUG +!d write (iout,*) "Gather dphi" +!d call flush(iout) + write (iout,*) "dphi before gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) + enddo +#endif + call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),& + MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,& + king,FG_COMM,IERROR) +!d write (iout,*) "Gather dalpha" +!d call flush(iout) +#ifdef CRYST_SC + call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),& + MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,& + king,FG_COMM,IERROR) +!d write (iout,*) "Gather domega" +!d call flush(iout) + call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),& + MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,& + king,FG_COMM,IERROR) +#endif + endif +#endif +#ifdef DEBUG + write (iout,*) "dtheta after gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2) + enddo + write (iout,*) "dphi after gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) + enddo + write (iout,*) "dalpha after gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3) + enddo + write (iout,*) "domega after gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3) + enddo +#endif + return + end subroutine intcartderiv +!----------------------------------------------------------------------------- + subroutine checkintcartgrad +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.SETUP' + real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres) + real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres) + real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres) + real(kind=8),dimension(3) :: dc_norm_s + real(kind=8) :: aincr=1.0d-5 + integer :: i,j + real(kind=8) :: dcji + do i=1,nres + phi_s(i)=phi(i) + theta_s(i)=theta(i) + alph_s(i)=alph(i) + omeg_s(i)=omeg(i) + enddo +! Check theta gradient + write (iout,*) & + "Analytical (upper) and numerical (lower) gradient of theta" + write (iout,*) + do i=3,nres + do j=1,3 + dcji=dc(j,i-2) + dc(j,i-2)=dcji+aincr + call chainbuild_cart + call int_from_cart1(.false.) + dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr + dc(j,i-2)=dcji + dcji=dc(j,i-1) + dc(j,i-1)=dc(j,i-1)+aincr + call chainbuild_cart + dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr + dc(j,i-1)=dcji + enddo +!el write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),& +!el (dtheta(j,2,i),j=1,3) +!el write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),& +!el (dthetanum(j,2,i),j=1,3) +!el write (iout,'(5x,3f10.5,5x,3f10.5)') & +!el (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),& +!el (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) +!el write (iout,*) + enddo +! Check gamma gradient + write (iout,*) & + "Analytical (upper) and numerical (lower) gradient of gamma" + do i=4,nres + do j=1,3 + dcji=dc(j,i-3) + dc(j,i-3)=dcji+aincr + call chainbuild_cart + dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr + dc(j,i-3)=dcji + dcji=dc(j,i-2) + dc(j,i-2)=dcji+aincr + call chainbuild_cart + dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr + dc(j,i-2)=dcji + dcji=dc(j,i-1) + dc(j,i-1)=dc(j,i-1)+aincr + call chainbuild_cart + dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr + dc(j,i-1)=dcji + enddo +!el write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),& +!el (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) +!el write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),& +!el (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) +!el write (iout,'(5x,3(3f10.5,5x))') & +!el (dphinum(j,1,i)/dphi(j,1,i),j=1,3),& +!el (dphinum(j,2,i)/dphi(j,2,i),j=1,3),& +!el (dphinum(j,3,i)/dphi(j,3,i),j=1,3) +!el write (iout,*) + enddo +! Check alpha gradient + write (iout,*) & + "Analytical (upper) and numerical (lower) gradient of alpha" + do i=2,nres-1 + if(itype(i).ne.10) then + do j=1,3 + dcji=dc(j,i-1) + dc(j,i-1)=dcji+aincr + call chainbuild_cart + dalphanum(j,1,i)=(alph(i)-alph_s(i)) & + /aincr + dc(j,i-1)=dcji + dcji=dc(j,i) + dc(j,i)=dcji+aincr + call chainbuild_cart + dalphanum(j,2,i)=(alph(i)-alph_s(i)) & + /aincr + dc(j,i)=dcji + dcji=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+aincr + call chainbuild_cart + dalphanum(j,3,i)=(alph(i)-alph_s(i)) & + /aincr + dc(j,i+nres)=dcji + enddo + endif +!el write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),& +!el (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) +!el write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),& +!el (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) +!el write (iout,'(5x,3(3f10.5,5x))') & +!el (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),& +!el (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),& +!el (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) +!el write (iout,*) + enddo +! Check omega gradient + write (iout,*) & + "Analytical (upper) and numerical (lower) gradient of omega" + do i=2,nres-1 + if(itype(i).ne.10) then + do j=1,3 + dcji=dc(j,i-1) + dc(j,i-1)=dcji+aincr + call chainbuild_cart + domeganum(j,1,i)=(omeg(i)-omeg_s(i)) & + /aincr + dc(j,i-1)=dcji + dcji=dc(j,i) + dc(j,i)=dcji+aincr + call chainbuild_cart + domeganum(j,2,i)=(omeg(i)-omeg_s(i)) & + /aincr + dc(j,i)=dcji + dcji=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+aincr + call chainbuild_cart + domeganum(j,3,i)=(omeg(i)-omeg_s(i)) & + /aincr + dc(j,i+nres)=dcji + enddo + endif +!el write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),& +!el (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) +!el write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),& +!el (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) +!el write (iout,'(5x,3(3f10.5,5x))') & +!el (domeganum(j,1,i)/domega(j,1,i),j=1,3),& +!el (domeganum(j,2,i)/domega(j,2,i),j=1,3),& +!el (domeganum(j,3,i)/domega(j,3,i),j=1,3) +!el write (iout,*) + enddo + return + end subroutine checkintcartgrad +!----------------------------------------------------------------------------- +! q_measure.F +!----------------------------------------------------------------------------- + real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' + integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg + integer :: kkk,nsep=3 + real(kind=8) :: qm !dist, + real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax + logical :: lprn=.false. + logical :: flag +! real(kind=8) :: sigm,x + +!el sigm(x)=0.25d0*x ! local function + qqmax=1.0d10 + do kkk=1,nperm + qq = 0.0d0 + nl=0 + if(flag) then + do il=seg1+nsep,seg2 + do jl=seg1,il-nsep + nl=nl+1 + d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + & + (cref(2,jl,kkk)-cref(2,il,kkk))**2 + & + (cref(3,jl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + enddo + enddo + qq = qq/nl + else + do il=seg1,seg2 + if((seg3-il).lt.3) then + secseg=il+3 + else + secseg=seg3 + endif + do jl=secseg,seg4 + nl=nl+1 + d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & + (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & + (cref(3,jl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + enddo + enddo + qq = qq/nl + endif + if (qqmax.le.qq) qqmax=qq + enddo + qwolynes=1.0d0-qqmax + return + end function qwolynes +!----------------------------------------------------------------------------- + subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.MD' + integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg + integer :: nsep=3, kkk +!el real(kind=8) :: dist + real(kind=8) :: dij,d0ij,dijCM,d0ijCM + logical :: lprn=.false. + logical :: flag + real(kind=8) :: sim,dd0,fac,ddqij +!el sigm(x)=0.25d0*x ! local function + do kkk=1,nperm + do i=0,nres + do j=1,3 + dqwol(j,i)=0.0d0 + dxqwol(j,i)=0.0d0 + enddo + enddo + nl=0 + if(flag) then + do il=seg1+nsep,seg2 + do jl=seg1,il-nsep + nl=nl+1 + d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & + (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & + (cref(3,jl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,jl) + sim = 1.0d0/sigm(d0ij) + sim = sim*sim + dd0 = dij-d0ij + fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il)-c(k,jl))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,jl+nres) + sim = 1.0d0/sigm(d0ijCM) + sim = sim*sim + dd0=dijCM-d0ijCM + fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il+nres)-c(k,jl+nres))*fac + dxqwol(k,il)=dxqwol(k,il)+ddqij + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + enddo + endif + enddo + enddo + else + do il=seg1,seg2 + if((seg3-il).lt.3) then + secseg=il+3 + else + secseg=seg3 + endif + do jl=secseg,seg4 + nl=nl+1 + d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & + (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & + (cref(3,jl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,jl) + sim = 1.0d0/sigm(d0ij) + sim = sim*sim + dd0 = dij-d0ij + fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il)-c(k,jl))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,jl+nres) + sim = 1.0d0/sigm(d0ijCM) + sim=sim*sim + dd0 = dijCM-d0ijCM + fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il+nres)-c(k,jl+nres))*fac + dxqwol(k,il)=dxqwol(k,il)+ddqij + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + enddo + endif + enddo + enddo + endif + enddo + do i=0,nres + do j=1,3 + dqwol(j,i)=dqwol(j,i)/nl + dxqwol(j,i)=dxqwol(j,i)/nl + enddo + enddo + return + end subroutine qwolynes_prim +!----------------------------------------------------------------------------- + subroutine qwol_num(seg1,seg2,flag,seg3,seg4) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' + integer :: seg1,seg2,seg3,seg4 + logical :: flag + real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan + real(kind=8),dimension(3,0:2*nres) :: cdummy + real(kind=8) :: q1,q2 + real(kind=8) :: delta=1.0d-10 + integer :: i,j + + do i=0,nres + do j=1,3 + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + cdummy(j,i)=c(j,i) + c(j,i)=c(j,i)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolan(j,i)=(q2-q1)/delta + c(j,i)=cdummy(j,i) + enddo + enddo + do i=0,nres + do j=1,3 + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + cdummy(j,i+nres)=c(j,i+nres) + c(j,i+nres)=c(j,i+nres)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolxan(j,i)=(q2-q1)/delta + c(j,i+nres)=cdummy(j,i+nres) + enddo + enddo +! write(iout,*) "Numerical Q carteisan gradients backbone: " +! do i=0,nct +! write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) +! enddo +! write(iout,*) "Numerical Q carteisan gradients side-chain: " +! do i=0,nct +! write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) +! enddo + return + end subroutine qwol_num +!----------------------------------------------------------------------------- + subroutine EconstrQ +! MD with umbrella_sampling using Wolyne's distance measure as a constraint +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' + use MD_data +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan + real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,& + duconst,duxconst + integer :: kstart,kend,lstart,lend,idummy + real(kind=8) :: delta=1.0d-7 + integer :: i,j,k,ii + do i=0,nres + do j=1,3 + duconst(j,i)=0.0d0 + dudconst(j,i)=0.0d0 + duxconst(j,i)=0.0d0 + dudxconst(j,i)=0.0d0 + enddo + enddo + Uconst=0.0d0 + do i=1,nfrag + qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,& + idummy,idummy) + Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) +! Calculating the derivatives of Constraint energy with respect to Q + Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),& + qinfrag(i,iset)) +! hm1=harmonic(qfrag(i,iset),qinfrag(i,iset)) +! hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset)) +! hmnum=(hm2-hm1)/delta +! write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset), +! & qinfrag(i,iset)) +! write(iout,*) "harmonicnum frag", hmnum +! Calculating the derivatives of Q with respect to cartesian coordinates + call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,& + idummy,idummy) +! write(iout,*) "dqwol " +! do ii=1,nres +! write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) +! enddo +! write(iout,*) "dxqwol " +! do ii=1,nres +! write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) +! enddo +! Calculating numerical gradients of dU/dQi and dQi/dxi +! call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. +! & ,idummy,idummy) +! The gradients of Uconst in Cs + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) + enddo + enddo + enddo + do i=1,npair + kstart=ifrag(1,ipair(1,i,iset),iset) + kend=ifrag(2,ipair(1,i,iset),iset) + lstart=ifrag(1,ipair(2,i,iset),iset) + lend=ifrag(2,ipair(2,i,iset),iset) + qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) + Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) +! Calculating dU/dQ + Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) +! hm1=harmonic(qpair(i),qinpair(i,iset)) +! hm2=harmonic(qpair(i)+delta,qinpair(i,iset)) +! hmnum=(hm2-hm1)/delta +! write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i), +! & qinpair(i,iset)) +! write(iout,*) "harmonicnum pair ", hmnum +! Calculating dQ/dXi + call qwolynes_prim(kstart,kend,.false.,& + lstart,lend) +! write(iout,*) "dqwol " +! do ii=1,nres +! write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) +! enddo +! write(iout,*) "dxqwol " +! do ii=1,nres +! write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) +! enddo +! Calculating numerical gradients +! call qwol_num(kstart,kend,.false. +! & ,lstart,lend) +! The gradients of Uconst in Cs + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) + enddo + enddo + enddo +! write(iout,*) "Uconst inside subroutine ", Uconst +! Transforming the gradients from Cs to dCs for the backbone + do i=0,nres + do j=i+1,nres + do k=1,3 + dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) + enddo + enddo + enddo +! Transforming the gradients from Cs to dCs for the side chains + do i=1,nres + do j=1,3 + dudxconst(j,i)=duxconst(j,i) + enddo + enddo +! write(iout,*) "dU/ddc backbone " +! do ii=0,nres +! write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) +! enddo +! write(iout,*) "dU/ddX side chain " +! do ii=1,nres +! write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) +! enddo +! Calculating numerical gradients of dUconst/ddc and dUconst/ddx +! call dEconstrQ_num + return + end subroutine EconstrQ +!----------------------------------------------------------------------------- + subroutine dEconstrQ_num +! Calculating numerical dUconst/ddc and dUconst/ddx +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.VAR' +! include 'COMMON.MD' + use MD_data +!#ifndef LANG0 +! include 'COMMON.LANGEVIN' +!#else +! include 'COMMON.LANGEVIN.lang0' +!#endif +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' + real(kind=8) :: uzap1,uzap2 + real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy + integer :: kstart,kend,lstart,lend,idummy + real(kind=8) :: delta=1.0d-7 +!el local variables + integer :: i,ii,j +! real(kind=8) :: +! For the backbone + do i=0,nres-1 + do j=1,3 + dUcartan(j,i)=0.0d0 + cdummy(j,i)=dc(j,i) + dc(j,i)=dc(j,i)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& + idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),& + qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),& + qinpair(ii,iset)) + enddo + dc(j,i)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& + idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),& + qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),& + qinpair(ii,iset)) + enddo + ducartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo +! Calculating numerical gradients for dU/ddx + do i=0,nres-1 + duxcartan(j,i)=0.0d0 + do j=1,3 + cdummy(j,i)=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& + idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),& + qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),& + qinpair(ii,iset)) + enddo + dc(j,i+nres)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),& + ifrag(2,ii,iset),.true.,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),& + qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),& + qinpair(ii,iset)) + enddo + duxcartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo + write(iout,*) "Numerical dUconst/ddc backbone " + do ii=0,nres + write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) + enddo +! write(iout,*) "Numerical dUconst/ddx side-chain " +! do ii=1,nres +! write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) +! enddo + return + end subroutine dEconstrQ_num +!----------------------------------------------------------------------------- +! ssMD.F +!----------------------------------------------------------------------------- + subroutine check_energies + +! use random, only: ran_number + +! implicit none +! Includes +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.SBRIDGE' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' + +! External functions +!EL double precision ran_number +!EL external ran_number + +! Local variables + integer :: i,j,k,l,lmax,p,pmax + real(kind=8) :: rmin,rmax + real(kind=8) :: eij + + real(kind=8) :: d + real(kind=8) :: wi,rij,tj,pj +! return + + i=5 + j=14 + + d=dsc(1) + rmin=2.0D0 + rmax=12.0D0 + + lmax=10000 + pmax=1 + + do k=1,3 + c(k,i)=0.0D0 + c(k,j)=0.0D0 + c(k,nres+i)=0.0D0 + c(k,nres+j)=0.0D0 + enddo + + do l=1,lmax + +!t wi=ran_number(0.0D0,pi) +! wi=ran_number(0.0D0,pi/6.0D0) +! wi=0.0D0 +!t tj=ran_number(0.0D0,pi) +!t pj=ran_number(0.0D0,pi) +! pj=ran_number(0.0D0,pi/6.0D0) +! pj=0.0D0 + + do p=1,pmax +!t rij=ran_number(rmin,rmax) + + c(1,j)=d*sin(pj)*cos(tj) + c(2,j)=d*sin(pj)*sin(tj) + c(3,j)=d*cos(pj) + + c(3,nres+i)=-rij + + c(1,i)=d*sin(wi) + c(3,i)=-rij-d*cos(wi) + + do k=1,3 + dc(k,nres+i)=c(k,nres+i)-c(k,i) + dc_norm(k,nres+i)=dc(k,nres+i)/d + dc(k,nres+j)=c(k,nres+j)-c(k,j) + dc_norm(k,nres+j)=dc(k,nres+j)/d + enddo + + call dyn_ssbond_ene(i,j,eij) + enddo + enddo + call exit(1) + return + end subroutine check_energies +!----------------------------------------------------------------------------- + subroutine dyn_ssbond_ene(resi,resj,eij) +! implicit none +! Includes + use calc_data + use comm_sschecks +! include 'DIMENSIONS' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM + use MD_data +! include 'COMMON.MD' +! use MD, only: totT,t_bath +#endif +#endif +! External functions +!EL double precision h_base +!EL external h_base + +! Input arguments + integer :: resi,resj + +! Output arguments + real(kind=8) :: eij + +! Local variables + logical :: havebond + integer itypi,itypj + real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi + real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2 + real(kind=8),dimension(3) :: dcosom1,dcosom2 + real(kind=8) :: ed + real(kind=8) :: pom1,pom2 + real(kind=8) :: ljA,ljB,ljXs + real(kind=8),dimension(1:3) :: d_ljB + real(kind=8) :: ssA,ssB,ssC,ssXs + real(kind=8) :: ssxm,ljxm,ssm,ljm + real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm + real(kind=8) :: f1,f2,h1,h2,hd1,hd2 + real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2 +!-------FIRST METHOD + real(kind=8) :: xm + real(kind=8),dimension(1:3) :: d_xm +!-------END FIRST METHOD +!-------SECOND METHOD +!$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) +!-------END SECOND METHOD + +!-------TESTING CODE +!el logical :: checkstop,transgrad +!el common /sschecks/ checkstop,transgrad + + integer :: icheck,nicheck,jcheck,njcheck + real(kind=8),dimension(-1:1) :: echeck + real(kind=8) :: deps,ssx0,ljx0 +!-------END TESTING CODE + + eij=0.0d0 + i=resi + j=resj + +!el allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres)) +!el allocate(dyn_ssbond_ij(0:nres+4,nres)) + + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + + itypj=itype(j) + xj=c(1,nres+j)-c(1,nres+i) + yj=c(2,nres+j)-c(2,nres+i) + zj=c(3,nres+j)-c(3,nres+i) + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse +! The following are set in sc_angular +! erij(1)=xj*rij +! erij(2)=yj*rij +! erij(3)=zj*rij +! om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) +! om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) +! om12=dxi*dxj+dyi*dyj+dzi*dzj + call sc_angular + rij=1.0D0/rij ! Reset this so it makes sense + + sig0ij=sigma(itypi,itypj) + sig=sig0ij*dsqrt(1.0D0/sigsq) + + ljXs=sig-sig0ij + ljA=eps1*eps2rt**2*eps3rt**2 + ljB=ljA*bb(itypi,itypj) + ljA=ljA*aa(itypi,itypj) + ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + + ssXs=d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + ssA=akcm + ssB=akct*deltat12 + ssC=ss_depth & + +akth*(deltat1*deltat1+deltat2*deltat2) & + +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi + ssxm=ssXs-0.5D0*ssB/ssA + +!-------TESTING CODE +!$$$c Some extra output +!$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +!$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) +!$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC +!$$$ if (ssx0.gt.0.0d0) then +!$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA +!$$$ else +!$$$ ssx0=ssxm +!$$$ endif +!$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +!$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", +!$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 +!$$$ return +!-------END TESTING CODE + +!-------TESTING CODE +! Stop and plot energy and derivative as a function of distance + if (checkstop) then + ssm=ssC-0.25D0*ssB*ssB/ssA + ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) + if (ssm.lt.ljm .and. & + dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then + nicheck=1000 + njcheck=1 + deps=0.5d-7 + else + checkstop=.false. + endif + endif + if (.not.checkstop) then + nicheck=0 + njcheck=-1 + endif + + do icheck=0,nicheck + do jcheck=-1,njcheck + if (checkstop) rij=(ssxm-1.0d0)+ & + ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps +!-------END TESTING CODE + + if (rij.gt.ljxm) then + havebond=.false. + ljd=rij-ljXs + fac=(1.0D0/ljd)**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + eij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=eij*eps3rt + eps3der=eij*eps2rt + eij=eij*eps2rt*eps3rt + + sigder=-sig/sigsq + e1=e1*eps1*eps2rt**2*eps3rt**2 + ed=-expon*(e1+eij)/ljd + sigder=ed*sigder + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=eij*eps1_om12+eps2der*eps2rt_om12 & + -2.0D0*alf12*eps3der+sigder*sigsq_om12 + else if (rij.lt.ssxm) then + havebond=.true. + ssd=rij-ssXs + eij=ssA*ssd*ssd+ssB*ssd+ssC + + ed=2*akcm*ssd+akct*deltat12 + pom1=akct*ssd + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + else + omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi + + d_ssxm(1)=0.5D0*akct/ssA + d_ssxm(2)=-d_ssxm(1) + d_ssxm(3)=0.0D0 + + d_ljxm(1)=sig0ij/sqrt(sigsq**3) + d_ljxm(2)=d_ljxm(1)*sigsq_om2 + d_ljxm(3)=d_ljxm(1)*sigsq_om12 + d_ljxm(1)=d_ljxm(1)*sigsq_om1 + +!-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + xm=0.5d0*(ssxm+ljxm) + do k=1,3 + d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) + enddo + if (rij.lt.xm) then + havebond=.true. + ssm=ssC-0.25D0*ssB*ssB/ssA + d_ssm(1)=0.5D0*akct*ssB/ssA + d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) + d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) + d_ssm(3)=omega + f1=(rij-xm)/(ssxm-xm) + f2=(rij-ssxm)/(xm-ssxm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=ssm*h1+Ht*h2 + delta_inv=1.0d0/(xm-ssxm) + deltasq_inv=delta_inv*delta_inv + fac=ssm*hd1-Ht*hd2 + fac1=deltasq_inv*fac*(xm-rij) + fac2=deltasq_inv*fac*(rij-ssxm) + ed=delta_inv*(Ht*hd2-ssm*hd1) + eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) + eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) + eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) + else + havebond=.false. + ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) + d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB + d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) + d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- & + alf12/eps3rt) + d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) + f1=(rij-ljxm)/(xm-ljxm) + f2=(rij-xm)/(ljxm-xm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=Ht*h1+ljm*h2 + delta_inv=1.0d0/(ljxm-xm) + deltasq_inv=delta_inv*delta_inv + fac=Ht*hd1-ljm*hd2 + fac1=deltasq_inv*fac*(ljxm-rij) + fac2=deltasq_inv*fac*(rij-xm) + ed=delta_inv*(ljm*hd2-Ht*hd1) + eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) + eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) + eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) + endif +!-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + +!-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE +!$$$ ssd=rij-ssXs +!$$$ ljd=rij-ljXs +!$$$ fac1=rij-ljxm +!$$$ fac2=rij-ssxm +!$$$ +!$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) +!$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) +!$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) +!$$$ +!$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +!$$$ d_ssm(1)=0.5D0*akct*ssB/ssA +!$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) +!$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) +!$$$ d_ssm(3)=omega +!$$$ +!$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) +!$$$ do k=1,3 +!$$$ d_ljm(k)=ljm*d_ljB(k) +!$$$ enddo +!$$$ ljm=ljm*ljB +!$$$ +!$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC +!$$$ d_ss(0)=2.0d0*ssA*ssd+ssB +!$$$ d_ss(2)=akct*ssd +!$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega +!$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega +!$$$ d_ss(3)=omega +!$$$ +!$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) +!$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) +!$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 +!$$$ do k=1,3 +!$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- +!$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) +!$$$ enddo +!$$$ ljf=ljm+ljf*ljB*fac1*fac1 +!$$$ +!$$$ f1=(rij-ljxm)/(ssxm-ljxm) +!$$$ f2=(rij-ssxm)/(ljxm-ssxm) +!$$$ h1=h_base(f1,hd1) +!$$$ h2=h_base(f2,hd2) +!$$$ eij=ss*h1+ljf*h2 +!$$$ delta_inv=1.0d0/(ljxm-ssxm) +!$$$ deltasq_inv=delta_inv*delta_inv +!$$$ fac=ljf*hd2-ss*hd1 +!$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac +!$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* +!$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) +!$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* +!$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) +!$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* +!$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) +!$$$ +!$$$ havebond=.false. +!$$$ if (ed.gt.0.0d0) havebond=.true. +!-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE + + endif + + if (havebond) then +!#ifndef CLUST +!#ifndef WHAM +! if (dyn_ssbond_ij(i,j).eq.1.0d300) then +! write(iout,'(a15,f12.2,f8.1,2i5)') +! & "SSBOND_E_FORM",totT,t_bath,i,j +! endif +!#endif +!#endif + dyn_ssbond_ij(i,j)=eij + else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then + dyn_ssbond_ij(i,j)=1.0d300 +!#ifndef CLUST +!#ifndef WHAM +! write(iout,'(a15,f12.2,f8.1,2i5)') +! & "SSBOND_E_BREAK",totT,t_bath,i,j +!#endif +!#endif + endif + +!-------TESTING CODE +!el if (checkstop) then + if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') & + "CHECKSTOP",rij,eij,ed + echeck(jcheck)=eij +!el endif + enddo + if (checkstop) then + write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps + endif + enddo + if (checkstop) then + transgrad=.true. + checkstop=.false. + endif +!-------END TESTING CODE + + do k=1,3 + dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij + dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij + enddo + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) & + +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & + +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) & + +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +!grad do k=i,j-1 +!grad do l=1,3 +!grad gvdwc(l,k)=gvdwc(l,k)+gg(l) +!grad enddo +!grad enddo + + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + + return + end subroutine dyn_ssbond_ene +!----------------------------------------------------------------------------- + real(kind=8) function h_base(x,deriv) +! A smooth function going 0->1 in range [0,1] +! It should NOT be called outside range [0,1], it will not work there. + implicit none + +! Input arguments + real(kind=8) :: x + +! Output arguments + real(kind=8) :: deriv + +! Local variables + real(kind=8) :: xsq + + +! Two parabolas put together. First derivative zero at extrema +!$$$ if (x.lt.0.5D0) then +!$$$ h_base=2.0D0*x*x +!$$$ deriv=4.0D0*x +!$$$ else +!$$$ deriv=1.0D0-x +!$$$ h_base=1.0D0-2.0D0*deriv*deriv +!$$$ deriv=4.0D0*deriv +!$$$ endif + +! Third degree polynomial. First derivative zero at extrema + h_base=x*x*(3.0d0-2.0d0*x) + deriv=6.0d0*x*(1.0d0-x) + +! Fifth degree polynomial. First and second derivatives zero at extrema +!$$$ xsq=x*x +!$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) +!$$$ deriv=x-1.0d0 +!$$$ deriv=deriv*deriv +!$$$ deriv=30.0d0*xsq*deriv + + return + end function h_base +!----------------------------------------------------------------------------- + subroutine dyn_set_nss +! Adjust nss and other relevant variables based on dyn_ssbond_ij +! implicit none + use MD_data, only: totT,t_bath +! Includes +! include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.SETUP' +! include 'COMMON.MD' +! Local variables + real(kind=8) :: emin + integer :: i,j,imin,ierr + integer :: diff,allnss,newnss + integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) + newihpb,newjhpb + logical :: found + integer,dimension(0:nfgtasks) :: i_newnss + integer,dimension(0:nfgtasks) :: displ + integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) + integer :: g_newnss + + allnss=0 + do i=1,nres-1 + do j=i+1,nres + if (dyn_ssbond_ij(i,j).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + endif + enddo + enddo + +!mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + 1 emin=1.0d300 + do i=1,allnss + if (allflag(i).eq.0 .and. & + dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then + emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) + imin=i + endif + enddo + if (emin.lt.1.0d300) then + allflag(imin)=1 + do i=1,allnss + if (allflag(i).eq.0 .and. & + (allihpb(i).eq.allihpb(imin) .or. & + alljhpb(i).eq.allihpb(imin) .or. & + allihpb(i).eq.alljhpb(imin) .or. & + alljhpb(i).eq.alljhpb(imin))) then + allflag(i)=-1 + endif + enddo + goto 1 + endif + +!mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + newnss=0 + do i=1,allnss + if (allflag(i).eq.1) then + newnss=newnss+1 + newihpb(newnss)=allihpb(i) + newjhpb(newnss)=alljhpb(i) + endif + enddo + +#ifdef MPI + if (nfgtasks.gt.1)then + + call MPI_Reduce(newnss,g_newnss,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) + call MPI_Gather(newnss,1,MPI_INTEGER,& + i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_newnss(i-1)+displ(i-1) + enddo + call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,& + g_newihpb,i_newnss,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,& + g_newjhpb,i_newnss,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + if(fg_rank.eq.0) then +! print *,'g_newnss',g_newnss +! print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) +! print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) + newnss=g_newnss + do i=1,newnss + newihpb(i)=g_newihpb(i) + newjhpb(i)=g_newjhpb(i) + enddo + endif + endif +#endif + + diff=newnss-nss + +!mc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) + + do i=1,nss + found=.false. + do j=1,newnss + if (idssb(i).eq.newihpb(j) .and. & + jdssb(i).eq.newjhpb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM + if (.not.found.and.fg_rank.eq.0) & + write(iout,'(a15,f12.2,f8.1,2i5)') & + "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) +#endif +#endif + enddo + + do i=1,newnss + found=.false. + do j=1,nss + if (newihpb(i).eq.idssb(j) .and. & + newjhpb(i).eq.jdssb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM + if (.not.found.and.fg_rank.eq.0) & + write(iout,'(a15,f12.2,f8.1,2i5)') & + "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) +#endif +#endif + enddo + + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo + + return + end subroutine dyn_set_nss +!----------------------------------------------------------------------------- +#ifdef WHAM + subroutine read_ssHist +! implicit none +! Includes +! include 'DIMENSIONS' +! include "DIMENSIONS.FREE" +! include 'COMMON.FREE' +! Local variables + integer :: i,j + character(len=80) :: controlcard + + do i=1,dyn_nssHist + call card_concat(controlcard,.true.) + read(controlcard,*) & + dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) + enddo + + return + end subroutine read_ssHist +#endif +!----------------------------------------------------------------------------- + integer function indmat(i,j) +!el +! get the position of the jth ijth fragment of the chain coordinate system +! in the fromto array. + integer :: i,j + + indmat=((2*(nres-2)-i)*(i-1))/2+j-1 + return + end function indmat +!----------------------------------------------------------------------------- + real(kind=8) function sigm(x) +!el + real(kind=8) :: x + sigm=0.25d0*x + return + end function sigm +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + subroutine alloc_ener_arrays +!EL Allocation of arrays used by module energy + +!el local variables + integer :: i,j + + if(nres.lt.100) then + maxconts=nres + elseif(nres.lt.200) then + maxconts=0.8*nres ! Max. number of contacts per residue + else + maxconts=0.6*nres ! (maxconts=maxres/4) + endif + maxcont=12*nres ! Max. number of SC contacts + maxvar=6*nres ! Max. number of variables +!el maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond + maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond +!---------------------- +! arrays in subroutine init_int_table +!el#ifdef MPI +!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) +!el#endif + allocate(nint_gr(nres)) + allocate(nscp_gr(nres)) + allocate(ielstart(nres)) + allocate(ielend(nres)) +!(maxres) + allocate(istart(nres,maxint_gr)) + allocate(iend(nres,maxint_gr)) +!(maxres,maxint_gr) + allocate(iscpstart(nres,maxint_gr)) + allocate(iscpend(nres,maxint_gr)) +!(maxres,maxint_gr) + allocate(ielstart_vdw(nres)) + allocate(ielend_vdw(nres)) +!(maxres) + + allocate(lentyp(0:nfgtasks-1)) +!(0:maxprocs-1) +!---------------------- +! commom.contacts +! common /contacts/ + if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont)) + allocate(icont(2,maxcont)) +!(2,maxcont) +! common /contacts1/ + allocate(num_cont(0:nres+4)) +!(maxres) + allocate(jcont(maxconts,nres)) +!(maxconts,maxres) + allocate(facont(maxconts,nres)) +!(maxconts,maxres) + allocate(gacont(3,maxconts,nres)) +!(3,maxconts,maxres) +! common /contacts_hb/ + allocate(gacontp_hb1(3,maxconts,nres)) + allocate(gacontp_hb2(3,maxconts,nres)) + allocate(gacontp_hb3(3,maxconts,nres)) + allocate(gacontm_hb1(3,maxconts,nres)) + allocate(gacontm_hb2(3,maxconts,nres)) + allocate(gacontm_hb3(3,maxconts,nres)) + allocate(gacont_hbr(3,maxconts,nres)) + allocate(grij_hb_cont(3,maxconts,nres)) +!(3,maxconts,maxres) + allocate(facont_hb(maxconts,nres)) + allocate(ees0p(maxconts,nres)) + allocate(ees0m(maxconts,nres)) + allocate(d_cont(maxconts,nres)) +!(maxconts,maxres) + allocate(num_cont_hb(nres)) +!(maxres) + allocate(jcont_hb(maxconts,nres)) +!(maxconts,maxres) +! common /rotat/ + allocate(Ug(2,2,nres)) + allocate(Ugder(2,2,nres)) + allocate(Ug2(2,2,nres)) + allocate(Ug2der(2,2,nres)) +!(2,2,maxres) + allocate(obrot(2,nres)) + allocate(obrot2(2,nres)) + allocate(obrot_der(2,nres)) + allocate(obrot2_der(2,nres)) +!(2,maxres) +! common /precomp1/ + allocate(mu(2,nres)) + allocate(muder(2,nres)) + allocate(Ub2(2,nres)) + Ub2(1,:)=0.0d0 + Ub2(2,:)=0.0d0 + allocate(Ub2der(2,nres)) + allocate(Ctobr(2,nres)) + allocate(Ctobrder(2,nres)) + allocate(Dtobr2(2,nres)) + allocate(Dtobr2der(2,nres)) +!(2,maxres) + allocate(EUg(2,2,nres)) + allocate(EUgder(2,2,nres)) + allocate(CUg(2,2,nres)) + allocate(CUgder(2,2,nres)) + allocate(DUg(2,2,nres)) + allocate(Dugder(2,2,nres)) + allocate(DtUg2(2,2,nres)) + allocate(DtUg2der(2,2,nres)) +!(2,2,maxres) +! common /precomp2/ + allocate(Ug2Db1t(2,nres)) + allocate(Ug2Db1tder(2,nres)) + allocate(CUgb2(2,nres)) + allocate(CUgb2der(2,nres)) +!(2,maxres) + allocate(EUgC(2,2,nres)) + allocate(EUgCder(2,2,nres)) + allocate(EUgD(2,2,nres)) + allocate(EUgDder(2,2,nres)) + allocate(DtUg2EUg(2,2,nres)) + allocate(Ug2DtEUg(2,2,nres)) +!(2,2,maxres) + allocate(Ug2DtEUgder(2,2,2,nres)) + allocate(DtUg2EUgder(2,2,2,nres)) +!(2,2,2,maxres) +! common /rotat_old/ + allocate(costab(nres)) + allocate(sintab(nres)) + allocate(costab2(nres)) + allocate(sintab2(nres)) +!(maxres) +! common /dipmat/ + allocate(a_chuj(2,2,maxconts,nres)) +!(2,2,maxconts,maxres)(maxconts=maxres/4) + allocate(a_chuj_der(2,2,3,5,maxconts,nres)) +!(2,2,3,5,maxconts,maxres)(maxconts=maxres/4) +! common /contdistrib/ + allocate(ncont_sent(nres)) + allocate(ncont_recv(nres)) + + allocate(iat_sent(nres)) +!(maxres) + allocate(iint_sent(4,nres,nres)) + allocate(iint_sent_local(4,nres,nres)) +!(4,maxres,maxres) + allocate(iturn3_sent(4,0:nres+4)) + allocate(iturn4_sent(4,0:nres+4)) + allocate(iturn3_sent_local(4,nres)) + allocate(iturn4_sent_local(4,nres)) +!(4,maxres) + allocate(itask_cont_from(0:nfgtasks-1)) + allocate(itask_cont_to(0:nfgtasks-1)) +!(0:max_fg_procs-1) + + + +!---------------------- +! commom.deriv; +! common /derivat/ + allocate(dcdv(6,maxdim)) + allocate(dxdv(6,maxdim)) +!(6,maxdim) + allocate(dxds(6,nres)) +!(6,maxres) + allocate(gradx(3,nres,0:2)) + allocate(gradc(3,nres,0:2)) +!(3,maxres,2) + allocate(gvdwx(3,nres)) + allocate(gvdwc(3,nres)) + allocate(gelc(3,nres)) + allocate(gelc_long(3,nres)) + allocate(gvdwpp(3,nres)) + allocate(gvdwc_scpp(3,nres)) + allocate(gradx_scp(3,nres)) + allocate(gvdwc_scp(3,nres)) + allocate(ghpbx(3,nres)) + allocate(ghpbc(3,nres)) + allocate(gradcorr(3,nres)) + allocate(gradcorr_long(3,nres)) + allocate(gradcorr5_long(3,nres)) + allocate(gradcorr6_long(3,nres)) + allocate(gcorr6_turn_long(3,nres)) + allocate(gradxorr(3,nres)) + allocate(gradcorr5(3,nres)) + allocate(gradcorr6(3,nres)) +!(3,maxres) + allocate(gloc(0:maxvar,0:2)) + allocate(gloc_x(0:maxvar,2)) +!(maxvar,2) + allocate(gel_loc(3,nres)) + allocate(gel_loc_long(3,nres)) + allocate(gcorr3_turn(3,nres)) + allocate(gcorr4_turn(3,nres)) + allocate(gcorr6_turn(3,nres)) + allocate(gradb(3,nres)) + allocate(gradbx(3,nres)) +!(3,maxres) + allocate(gel_loc_loc(maxvar)) + allocate(gel_loc_turn3(maxvar)) + allocate(gel_loc_turn4(maxvar)) + allocate(gel_loc_turn6(maxvar)) + allocate(gcorr_loc(maxvar)) + allocate(g_corr5_loc(maxvar)) + allocate(g_corr6_loc(maxvar)) +!(maxvar) + allocate(gsccorc(3,nres)) + allocate(gsccorx(3,nres)) +!(3,maxres) + allocate(gsccor_loc(nres)) +!(maxres) + allocate(dtheta(3,2,nres)) +!(3,2,maxres) + allocate(gscloc(3,nres)) + allocate(gsclocx(3,nres)) +!(3,maxres) + allocate(dphi(3,3,nres)) + allocate(dalpha(3,3,nres)) + allocate(domega(3,3,nres)) +!(3,3,maxres) +! common /deriv_scloc/ + allocate(dXX_C1tab(3,nres)) + allocate(dYY_C1tab(3,nres)) + allocate(dZZ_C1tab(3,nres)) + allocate(dXX_Ctab(3,nres)) + allocate(dYY_Ctab(3,nres)) + allocate(dZZ_Ctab(3,nres)) + allocate(dXX_XYZtab(3,nres)) + allocate(dYY_XYZtab(3,nres)) + allocate(dZZ_XYZtab(3,nres)) +!(3,maxres) +! common /mpgrad/ + allocate(jgrad_start(nres)) + allocate(jgrad_end(nres)) +!(maxres) +!---------------------- + +! common /indices/ + allocate(ibond_displ(0:nfgtasks-1)) + allocate(ibond_count(0:nfgtasks-1)) + allocate(ithet_displ(0:nfgtasks-1)) + allocate(ithet_count(0:nfgtasks-1)) + allocate(iphi_displ(0:nfgtasks-1)) + allocate(iphi_count(0:nfgtasks-1)) + allocate(iphi1_displ(0:nfgtasks-1)) + allocate(iphi1_count(0:nfgtasks-1)) + allocate(ivec_displ(0:nfgtasks-1)) + allocate(ivec_count(0:nfgtasks-1)) + allocate(iset_displ(0:nfgtasks-1)) + allocate(iset_count(0:nfgtasks-1)) + allocate(iint_count(0:nfgtasks-1)) + allocate(iint_displ(0:nfgtasks-1)) +!(0:max_fg_procs-1) +!---------------------- +! common.MD +! common /mdgrad/ + allocate(gcart(3,0:nres)) + allocate(gxcart(3,0:nres)) +!(3,0:MAXRES) + allocate(gradcag(3,nres)) + allocate(gradxag(3,nres)) +!(3,MAXRES) +! common /back_constr/ +!el in energy:Econstr_back allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back) + allocate(dutheta(nres)) + allocate(dugamma(nres)) +!(maxres) + allocate(duscdiff(3,nres)) + allocate(duscdiffx(3,nres)) +!(3,maxres) +!el i io:read_fragments +! allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20) +! allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20) +! common /qmeas/ +! allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20) +! allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20) + allocate(mset(0:nprocs)) !(maxprocs/20) + mset(:)=0 +! allocate(ifrag(2,50,nprocs/20)) !(2,50,maxprocs/20) +! allocate(ipair(2,100,nprocs/20)) !(2,100,maxprocs/20) + allocate(dUdconst(3,0:nres)) + allocate(dUdxconst(3,0:nres)) + allocate(dqwol(3,0:nres)) + allocate(dxqwol(3,0:nres)) +!(3,0:MAXRES) +!---------------------- +! common.sbridge +! common /sbridge/ in io_common: read_bridge +!el allocate((:),allocatable :: iss !(maxss) +! common /links/ in io_common: read_bridge +!el real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane +!el integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane +! common /dyn_ssbond/ +! and side-chain vectors in theta or phi. + allocate(dyn_ssbond_ij(0:nres+4,0:nres+4)) +!(maxres,maxres) +! do i=1,nres +! do j=i+1,nres + dyn_ssbond_ij(:,:)=1.0d300 +! enddo +! enddo + + if (nss.gt.0) then + allocate(idssb(nss),jdssb(nss)) +!(maxdim) + endif + allocate(dyn_ss_mask(nres)) +!(maxres) + dyn_ss_mask(:)=.false. +!---------------------- +! common.sccor +! Parameters of the SCCOR term +! common/sccor/ +!el in io_conf: parmread +! allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) +! allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) +! allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) +! allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) +! allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp)) +! allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp) +! allocate(vlor1sccor(maxterm_sccor,20,20)) +! allocate(vlor2sccor(maxterm_sccor,20,20)) +! allocate(vlor3sccor(maxterm_sccor,20,20)) !(maxterm_sccor,20,20) +!---------------- + allocate(gloc_sc(3,0:2*nres,0:10)) +!(3,0:maxres2,10)maxres2=2*maxres + allocate(dcostau(3,3,3,2*nres)) + allocate(dsintau(3,3,3,2*nres)) + allocate(dtauangle(3,3,3,2*nres)) + allocate(dcosomicron(3,3,3,2*nres)) + allocate(domicron(3,3,3,2*nres)) +!(3,3,3,maxres2)maxres2=2*maxres +!---------------------- +! common.var +! common /restr/ + allocate(varall(maxvar)) +!(maxvar)(maxvar=6*maxres) + allocate(mask_theta(nres)) + allocate(mask_phi(nres)) + allocate(mask_side(nres)) +!(maxres) +!---------------------- +! common.vectors +! common /vectors/ + allocate(uy(3,nres)) + allocate(uz(3,nres)) +!(3,maxres) + allocate(uygrad(3,3,2,nres)) + allocate(uzgrad(3,3,2,nres)) +!(3,3,2,maxres) + + return + end subroutine alloc_ener_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module energy diff --git a/source/unres/energy.f90 b/source/unres/energy.f90 deleted file mode 100644 index fdf4576..0000000 --- a/source/unres/energy.f90 +++ /dev/null @@ -1,16248 +0,0 @@ - module energy -!----------------------------------------------------------------------------- - use io_units - use names - use math - use MPI_data - use energy_data - use control_data - use geometry_data - use geometry -! - implicit none -!----------------------------------------------------------------------------- -! Max. number of contacts per residue -! integer :: maxconts -!----------------------------------------------------------------------------- -! Max. number of derivatives of virtual-bond and side-chain vectors in theta -! or phi. -! integer :: maxdim -!----------------------------------------------------------------------------- -! Max. number of SC contacts -! integer :: maxcont -!----------------------------------------------------------------------------- -! Max. number of variables - integer :: maxvar -!----------------------------------------------------------------------------- -! Max number of torsional terms in SCCOR in control_data -! integer,parameter :: maxterm_sccor=6 -!----------------------------------------------------------------------------- -! Maximum number of SC local term fitting function coefficiants - integer,parameter :: maxsccoef=65 -!----------------------------------------------------------------------------- -! commom.calc common/calc/ -!----------------------------------------------------------------------------- -! commom.contacts -! common /contacts/ -! Change 12/1/95 - common block CONTACTS1 included. -! common /contacts1/ - integer,dimension(:),allocatable :: num_cont !(maxres) - integer,dimension(:,:),allocatable :: jcont !(maxconts,maxres) - real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres) - real(kind=8),dimension(:,:,:),allocatable :: gacont !(3,maxconts,maxres) -! -! 12/26/95 - H-bonding contacts -! common /contacts_hb/ - real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,& - gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont !(3,maxconts,maxres) - real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,& - ees0m,d_cont !(maxconts,maxres) - integer,dimension(:),allocatable :: num_cont_hb !(maxres) - integer,dimension(:,:),allocatable :: jcont_hb !(maxconts,maxres) -! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -! interactions -! 7/25/08 commented out; not needed when cumulants used -! Interactions of pseudo-dipoles generated by loc-el interactions. -! common /dipint/ - real(kind=8),dimension(:,:,:),allocatable :: dip,& - dipderg !(4,maxconts,maxres) - real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres) -! 10/30/99 Added other pre-computed vectors and matrices needed -! to calculate three - six-order el-loc correlation terms -! common /rotat/ - real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der !(2,2,maxres) - real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,& - obrot2_der !(2,maxres) -! -! This common block contains vectors and matrices dependent on a single -! amino-acid residue. -! common /precomp1/ - real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,& - Ctobr,Ctobrder,Dtobr2,Dtobr2der !(2,maxres) - real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,& - CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres) -! This common block contains vectors and matrices dependent on two -! consecutive amino-acid residues. -! common /precomp2/ - real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,& - CUgb2,CUgb2der !(2,maxres) - real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,& - EUgD,EUgDder,DtUg2EUg,Ug2DtEUg !(2,2,maxres) - real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,& - DtUg2EUgder !(2,2,2,maxres) -! common /rotat_old/ - real(kind=8),dimension(:),allocatable :: costab,sintab,& - costab2,sintab2 !(maxres) -! This common block contains dipole-interaction matrices and their -! Cartesian derivatives. -! common /dipmat/ - real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj !(2,2,maxconts,maxres) - real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der !(2,2,3,5,maxconts,maxres) -! common /diploc/ - real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,& - AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2 - real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,& - ADtEA1derg,AEAb2derg - real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,& - AECAderx,ADtEAderx,ADtEA1derx - real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx - real(kind=8),dimension(3,2) :: g_contij - real(kind=8) :: ekont -! 12/13/2008 (again Poland-Jaruzel war anniversary) -! RE: Parallelization of 4th and higher order loc-el correlations -! common /contdistrib/ - integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres) -! ncont_sent,ncont_recv są w multibody_ello i multibody_hb -!----------------------------------------------------------------------------- -! commom.deriv; -! common /derivat/ -! real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim) -! real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres) -! real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2) - real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,& - gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,& - gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,& - gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres) -! real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2) - real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,& - gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres) - real(kind=8),dimension(:),allocatable :: gel_loc_loc,& - gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,& - g_corr6_loc !(maxvar) - real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres) - real(kind=8),dimension(:),allocatable :: gsccor_loc !(maxres) -! real(kind=8),dimension(:,:,:),allocatable :: dtheta !(3,2,maxres) - real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres) -! real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres) -! integer :: nfl,icg -! common /deriv_loc/ - real(kind=8),dimension(3,5,2) :: derx,derx_turn -! common /deriv_scloc/ - real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,& - dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,& - dZZ_XYZtab !(3,maxres) -!----------------------------------------------------------------------------- -! common.maxgrad -! common /maxgrad/ - real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,& - gradb_max,ghpbc_max,& - gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,& - gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,& - gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,& - gsccorx_max,gsclocx_max -!----------------------------------------------------------------------------- -! common.MD -! common /back_constr/ - real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres) - real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres) -! common /qmeas/ - real(kind=8) :: Ucdfrag,Ucdpair - real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,& - dqwol,dxqwol !(3,0:MAXRES) -!----------------------------------------------------------------------------- -! common.sbridge -! common /dyn_ssbond/ - real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres) -!----------------------------------------------------------------------------- -! common.sccor -! Parameters of the SCCOR term -! common/sccor/ - real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,& - dcosomicron,domicron !(3,3,3,maxres2) -!----------------------------------------------------------------------------- -! common.vectors -! common /vectors/ - real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres) - real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres) -!----------------------------------------------------------------------------- -! common /przechowalnia/ - real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs) - real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! energy_p_new_barrier.F -!----------------------------------------------------------------------------- - subroutine etotal(energia) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use MD_data, only: totT -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' - real(kind=8),dimension(0:n_ene) :: energia -! include 'COMMON.LOCAL' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.CONTROL' -! include 'COMMON.TIME1' - real(kind=8) :: time00 -!el local variables - integer :: n_corr,n_corr1,ierror - real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb - real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc - real(kind=8) :: eello_turn3,eello_turn4,estr,ebe - real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 - -#ifdef MPI - real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw -! print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -! & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -! FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -! print *,"Processor",myrank," BROADCAST iorder" -! FG master sets up the WEIGHTS_ array which will be broadcast to the -! FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -! FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene,& - MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -! FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene,& - MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -! call chainbuild_cart - endif -! print *,'Processor',myrank,' calling etotal ipot=',ipot -! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -! if (modecalc.eq.12.or.modecalc.eq.14) then -! call int_from_cart1(.false.) -! endif -#endif -#ifdef TIMING - time00=MPI_Wtime() -#endif -! -! Compute the side-chain and electrostatic interaction energy -! -! goto (101,102,103,104,105,106) ipot - select case(ipot) -! Lennard-Jones potential. -! 101 call elj(evdw) - case (1) - call elj(evdw) -!d print '(a)','Exit ELJcall el' -! goto 107 -! Lennard-Jones-Kihara potential (shifted). -! 102 call eljk(evdw) - case (2) - call eljk(evdw) -! goto 107 -! Berne-Pechukas potential (dilated LJ, angular dependence). -! 103 call ebp(evdw) - case (3) - call ebp(evdw) -! goto 107 -! Gay-Berne potential (shifted LJ, angular dependence). -! 104 call egb(evdw) - case (4) - call egb(evdw) -! goto 107 -! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). -! 105 call egbv(evdw) - case (5) - call egbv(evdw) -! goto 107 -! Soft-sphere potential -! 106 call e_softsphere(evdw) - case (6) - call e_softsphere(evdw) -! -! Calculate electrostatic (H-bonding) energy of the main chain. -! -! 107 continue - case default - write(iout,*)"Wrong ipot" -! return -! 50 continue - end select -! continue - -!mc -!mc Sep-06: egb takes care of dynamic ss bonds too -!mc -! if (dyn_ss) call dyn_set_nss -! print *,"Processor",myrank," computed USCSC" -#ifdef TIMING - time01=MPI_Wtime() -#endif - call vec_and_deriv -#ifdef TIMING - time_vec=time_vec+MPI_Wtime()-time01 -#endif -! print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. & - wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & - .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & - .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. & - wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & - .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & - .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -! write (iout,*) "ELEC calc" - else - ees=0.0d0 - evdw1=0.0d0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - endif - else -! write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,& - eello_turn4) - endif -! print *,"Processor",myrank," computed UELEC" -! -! Calculate excluded-volume interaction energy between peptide groups -! and side chains. -! -!elwrite(iout,*) "in etotal calc exc;luded",ipot - - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -! write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -!elwrite(iout,*) "in etotal before ebond",ipot - -! -! Calculate the bond-stretching energy -! - call ebond(estr) -!elwrite(iout,*) "in etotal afer ebond",ipot - -! -! Calculate the disulfide-bridge and other energy and the contributions -! from other distance constraints. -! print *,'Calling EHPB' - call edis(ehpb) -!elwrite(iout,*) "in etotal afer edis",ipot -! print *,'EHPB exitted succesfully.' -! -! Calculate the virtual-bond-angle energy. -! - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -! print *,"Processor",myrank," computed UB" -! -! Calculate the SC local energy. -! - call esc(escloc) -!elwrite(iout,*) "in etotal afer esc",ipot -! print *,"Processor",myrank," computed USC" -! -! Calculate the virtual-bond torsional energy. -! -!d print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -! print *,"Processor",myrank," computed Utor" -! -! 6/23/01 Calculate double-torsional energy -! -!elwrite(iout,*) "in etotal",ipot - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -! print *,"Processor",myrank," computed Utord" -! -! 21/5/07 Calculate local sicdechain correlation energy -! - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -! print *,"Processor",myrank," computed Usccorr" -! -! 12/1/95 Multi-body terms -! - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 & - .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -!d write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -!d &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif -!elwrite(iout,*) "in etotal",ipot - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -!d write (iout,*) "multibody_hb ecorr",ecorr - endif -!elwrite(iout,*) "afeter multibody hb" - -! print *,"Processor",myrank," computed Ucorr" -! -! If performing constraint dynamics, call the constraint energy -! after the equilibration time - if(usampl.and.totT.gt.eq_time) then -!elwrite(iout,*) "afeter multibody hb" - call EconstrQ -!elwrite(iout,*) "afeter multibody hb" - call Econstr_back -!elwrite(iout,*) "afeter multibody hb" - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -!elwrite(iout,*) "after Econstr" - -#ifdef TIMING - time_enecalc=time_enecalc+MPI_Wtime()-time00 -#endif -! print *,"Processor",myrank," computed Uconstr" -#ifdef TIMING - time00=MPI_Wtime() -#endif -! -! Sum the energies -! - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor -! Here are the energies showed per procesor if the are more processors -! per molecule then we sum it up in sum_energy subroutine -! print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) - if (dyn_ss) call dyn_set_nss -! print *," Processor",myrank," left SUM_ENERGY" -#ifdef TIMING - time_sumene=time_sumene+MPI_Wtime()-time00 -#endif -!el call enerprint(energia) -!elwrite(iout,*)"finish etotal" - return - end subroutine etotal -!----------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' - real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1) -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.CONTROL' -! include 'COMMON.TIME1' - logical :: reduce - real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6 - real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc - real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot - integer :: i -#ifdef MPI - integer :: ierr - real(kind=8) :: time00 - if (nfgtasks.gt.1 .and. reduce) then - -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_e=time_barrier_e+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1,& - MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif - evdw=energia(1) -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 & - +wang*ebe+wtor*etors+wscloc*escloc & - +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & - +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 & - +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & - +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) & - +wang*ebe+wtor*etors+wscloc*escloc & - +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & - +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 & - +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & - +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -! detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif -! call enerprint(energia) - call flush(iout) - return - end subroutine sum_energy -!----------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) -! implicit real*8 (a-h,o-z) -#ifdef MPI - include 'mpif.h' -#endif -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' - real(kind=8) :: kfac=2.4d0 - real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644 -!el local variables - real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6 - real(kind=8) :: T0=3.0d2 - integer :: ierror -! facT=temp0/t_bath -! facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT(1)=1.0d0 - facT(2)=1.0d0 - facT(3)=1.0d0 - facT(4)=1.0d0 - facT(5)=1.0d0 - facT(6)=1.0d0 - else if (rescale_mode.eq.1) then - facT(1)=kfac/(kfac-1.0d0+t_bath/temp0) - facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) -#ifdef WHAM_RUN -!#if defined(WHAM_RUN) || defined(CLUSTER) -#if defined(FUNCTH) -! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) - facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 -#elif defined(FUNCT) - facT(6)=t_bath/T0 -#else - facT(6)=1.0d0 -#endif -#endif - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT(1)=licznik/dlog(dexp(x)+dexp(-x)) - facT(2)=licznik/dlog(dexp(x2)+dexp(-x2)) - facT(3)=licznik/dlog(dexp(x3)+dexp(-x3)) - facT(4)=licznik/dlog(dexp(x4)+dexp(-x4)) - facT(5)=licznik/dlog(dexp(x5)+dexp(-x5)) -#ifdef WHAM_RUN -!#if defined(WHAM_RUN) || defined(CLUSTER) -#if defined(FUNCTH) - facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 -#elif defined(FUNCT) - facT(6)=t_bath/T0 -#else - facT(6)=1.0d0 -#endif -#endif - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact(1) - wcorr=weights(4)*fact(3) - wcorr5=weights(5)*fact(4) - wcorr6=weights(6)*fact(5) - wel_loc=weights(7)*fact(2) - wturn3=weights(8)*fact(2) - wturn4=weights(9)*fact(3) - wturn6=weights(10)*fact(5) - wtor=weights(13)*fact(1) - wtor_d=weights(14)*fact(2) - wsccor=weights(21)*fact(1) - - return - end subroutine rescale_weights -!----------------------------------------------------------------------------- - subroutine enerprint(energia) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.MD' - real(kind=8) :: energia(0:n_ene) -!el local variables - real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc - real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc - real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor - - etot=energia(0) - evdw=energia(1) - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,& - estr,wbond,ebe,wang,& - escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,& - ecorr,wcorr,& - ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,& - eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,& - edihcnstr,ebr*nss,& - Uconst,etot - 10 format (/'Virtual-chain energies:'// & - 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & - 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & - 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ & - 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ & - 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & - 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & - 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & - 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & - 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & - 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & - ' (SS bridges & dist. cnstr.)'/ & - 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & - 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & - 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & - 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & - 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & - 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & - 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & - 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & - 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & - 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & - 'UCONST= ',1pE16.6,' (Constraint energy)'/ & - 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,& - estr,wbond,ebe,wang,& - escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,& - ecorr,wcorr,& - ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,& - eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,& - ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// & - 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & - 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & - 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ & - 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & - 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & - 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & - 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & - 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & - 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & - ' (SS bridges & dist. cnstr.)'/ & - 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & - 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & - 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & - 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & - 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & - 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & - 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & - 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & - 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & - 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & - 'UCONST=',1pE16.6,' (Constraint energy)'/ & - 'ETOT= ',1pE16.6,' (total)') -#endif - return - end subroutine enerprint -!----------------------------------------------------------------------------- - subroutine elj(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the LJ potential of interaction. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - real(kind=8),parameter :: accur=1.0d-10 -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.TORSION' -! include 'COMMON.SBRIDGE' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTACTS' - real(kind=8),dimension(3) :: gg - integer :: num_conti -!el local variables - integer :: i,itypi,iint,j,itypi1,itypj,k - real(kind=8) :: rij,rcut,fcont,fprimcont,rrij - real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj - real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij - -! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -! allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2 -! allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4) -! allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) -! allocate(gacont(3,nres/4,iatsc_s:iatsc_e)) !(3,maxconts,maxres) - - do i=iatsc_s,iatsc_e - itypi=iabs(itype(i)) - if (itypi.eq.ntyp1) cycle - itypi1=iabs(itype(i+1)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -! Change 12/1/95 - num_conti=0 -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) -!d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -!d & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=iabs(itype(j)) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -! Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - rrij=1.0D0/rij -! write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -!d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -!d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -!d write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -!d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -!d & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -!d & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij -! -! Calculate the components of the gradient in DC and X -! - fac=-rrij*(e1+evdwij) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo -!grad do k=i,j-1 -!grad do l=1,3 -!grad gvdwc(l,k)=gvdwc(l,k)+gg(l) -!grad enddo -!grad enddo -! -! 12/1/95, revised on 5/20/97 -! -! Calculate the contact function. The ith column of the array JCONT will -! contain the numbers of atoms that make contacts with the atom I (of numbers -! greater than I). The arrays FACONT and GACONT will contain the values of -! the contact function and its derivative. -! -! Uncomment next line, if the correlation interactions include EVDW explicitly. -! if (j.gt.i+1 .and. evdwij.le.0.0D0) then -! Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -! -! Check whether the SC's are not too far to make a contact. -! - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -! Add a new contact, if the SC's are close enough, but not too close (ri' -!grad do k=1,3 -!grad ggg(k)=-ggg(k) -! Uncomment following line for SC-p interactions -! gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -!grad enddo -!grad endif -!grad do k=1,3 -!grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -!grad enddo -!grad kstart=min0(i+1,j) -!grad kend=max0(i-1,j-1) -!d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -!d write (iout,*) ggg(1),ggg(2),ggg(3) -!grad do k=kstart,kend -!grad do l=1,3 -!grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -!grad enddo -!grad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - return - end subroutine escp_soft_sphere -!----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -! -! This subroutine calculates the excluded-volume interaction energy between -! peptide-group centers and side chains and its gradient in virtual-bond and -! side-chain vectors. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' - real(kind=8),dimension(3) :: ggg -!el local variables - integer :: i,iint,j,k,iteli,itypj - real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,& - e1,e2,evdwij - - evdw2=0.0D0 - evdw2_14=0.0d0 -!d print '(a)','Enter ESCP' -!d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=iabs(itype(j)) - if (itypj.eq.ntyp1) cycle -! Uncomment following three lines for SC-p interactions -! xj=c(1,nres+j)-xi -! yj=c(2,nres+j)-yi -! zj=c(3,nres+j)-zi -! Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij -! if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') & -! 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),& - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'evdw2',i,j,evdwij -! -! Calculate contributions to the gradient in the virtual-bond and SC vectors. -! - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -!grad if (j.lt.i) then -!d write (iout,*) 'ji' -!grad do k=1,3 -!grad ggg(k)=-ggg(k) -! Uncomment following line for SC-p interactions -!cgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -!grad enddo -!grad endif -!grad do k=1,3 -!grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -!grad enddo -!grad kstart=min0(i+1,j) -!grad kend=max0(i-1,j-1) -!d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -!d write (iout,*) ggg(1),ggg(2),ggg(3) -!grad do k=kstart,kend -!grad do l=1,3 -!grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -!grad enddo -!grad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -!****************************************************************************** -! -! N O T E !!! -! -! To save time the factor EXPON has been extracted from ALL components -! of GVDWC and GRADX. Remember to multiply them by this factor before further -! use! -! -!****************************************************************************** - return - end subroutine escp -!----------------------------------------------------------------------------- - subroutine edis(ehpb) -! -! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' - real(kind=8),dimension(3) :: ggg -!el local variables - integer :: i,j,ii,jj,iii,jjj,k - real(kind=8) :: fac,eij,rdis,ehpb,dd,waga - - ehpb=0.0D0 -!d write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -!d write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -! CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -! iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -! write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, -! & dhpb(i),dhpb1(i),forcon(i) -! 24/11/03 AL: SS bridges handled separately because of introducing a specific -! distance and angle dependent SS bond potential. -!mc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then -! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds - if (.not.dyn_ss .and. i.le.nss) then -! 15/02/13 CC dynamic SSbond - additional check - if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. & - iabs(itype(jjj)).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -!d write (iout,*) "eij",eij - endif - else -! Calculate the distance between the two points and its difference from the -! target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -! Get the force constant corresponding to this distance. - waga=forcon(i) -! Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -! -! Evaluate gradient. -! - fac=waga*rdis/dd -!d print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -!d & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -!d print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -! If this is a SC-SC distance, we need to calculate the contributions to the -! Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -!grad do j=iii,jjj-1 -!grad do k=1,3 -!grad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -!grad enddo -!grad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end subroutine edis -!----------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -! -! Calculate the distance and angle dependent SS-bond potential energy -! using a free-energy function derived based on RHF/6-31G** ab initio -! calculations of diethyl disulfide. -! -! A. Liwo and U. Kozlowska, 11/24/03 -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' - real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg -!el local variables - integer :: i,j,itypi,itypj,k - real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,& - xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,& - deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,& - cosphi,ggk - - itypi=iabs(itype(i)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(nres+i) - itypj=iabs(itype(j)) -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(nres+j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) & - +akct*deltad*deltat12 & - +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr -! write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -! & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -! & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - ghpbx(k,i)=ghpbx(k,i)-ggk & - +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & - +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+ggk & - +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & - +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - ghpbc(k,i)=ghpbc(k,i)-ggk - ghpbc(k,j)=ghpbc(k,j)+ggk - enddo -! -! Calculate the components of the gradient in DC and X -! -!grad do k=i,j-1 -!grad do l=1,3 -!grad ghpbc(l,k)=ghpbc(l,k)+gg(l) -!grad enddo -!grad enddo - return - end subroutine ssbond_ene -!----------------------------------------------------------------------------- - subroutine ebond(estr) -! -! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.FFIELD' -! include 'COMMON.CONTROL' -! include 'COMMON.SETUP' - real(kind=8),dimension(3) :: u,ud -!el local variables - integer :: i,j,iti,nbi,k - real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,& - uprod1,uprod2 - - estr=0.0d0 - estr1=0.0d0 -! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) -! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) - - do i=ibondp_start,ibondp_end - if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then - estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) - do j=1,3 - gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) & - *dc(j,i-1)/vbld(i) - enddo - if (energy_dec) write(iout,*) & - "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) - else - diff = vbld(i)-vbldp0 - if (energy_dec) write (iout,'(a7,i5,4f7.3)') & - "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -! write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - endif - enddo - estr=0.5d0*AKP*estr+estr1 -! -! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -! - do i=ibond_start,ibond_end - iti=iabs(itype(i)) - if (iti.ne.10 .and. iti.ne.ntyp1) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) - if (energy_dec) write (iout,*) & - "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,& - AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end subroutine ebond -#ifdef CRYST_THETA -!----------------------------------------------------------------------------- - subroutine ebend(etheta) -! -! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -! angles gamma and its derivatives in consecutive thetas and gammas. -! - use comm_calcthet -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.FFIELD' -! include 'COMMON.CONTROL' -!el real(kind=8) :: term1,term2,termm,diffak,ratak,& -!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& -!el delthe0,sig0inv,sigtc,sigsqtc,delthec -!el integer :: it -!el common /calcthet/ term1,term2,termm,diffak,ratak,& -!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& -!el delthe0,sig0inv,sigtc,sigsqtc,delthec,it -!el local variables - integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,& - ichir21,ichir22 - real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,& - athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,& - f1,fprim1,E_tc1,ethetai,E_theta,E_tc - real(kind=8),dimension(2) :: y,z - - delta=0.02d0*pi -! time11=dexp(-2*time) -! time12=1.0d0 - etheta=0.0D0 -! write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end - if (itype(i-1).eq.ntyp1) cycle -! Zero the energy function and its derivative at 0 or pi. - call splinthet(theta(i),0.5d0*delta,ss,ssd) - it=itype(i-1) - ichir1=isign(1,itype(i-2)) - ichir2=isign(1,itype(i)) - if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) - if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) - if (itype(i-1).eq.10) then - itype1=isign(10,itype(i-2)) - ichir11=isign(1,itype(i-2)) - ichir12=isign(1,itype(i-2)) - itype2=isign(10,itype(i)) - ichir21=isign(1,itype(i)) - ichir22=isign(1,itype(i)) - endif - - if (i.gt.3 .and. itype(i-2).ne.ntyp1) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres .and. itype(i).ne.ntyp1) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -! Calculate the "mean" value of theta from the part of the distribution -! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -! In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it,ichir1,ichir2) - bthetk=bthet(k,it,ichir1,ichir2) - if (it.eq.10) then - athetk=athet(k,itype1,ichir11,ichir12) - bthetk=bthet(k,itype2,ichir21,ichir22) - endif - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -! Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) & - +athet(2,it,ichir1,ichir2)*y(1))*ss - dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) & - +bthet(2,it,ichir1,ichir2)*z(1))*ss - if (it.eq.10) then - dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) & - +athet(2,itype1,ichir11,ichir12)*y(1))*ss - dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) & - +bthet(2,itype2,ichir21,ichir22)*z(1))*ss - endif - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,& - E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,& - E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,& - E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,& - E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,& - E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,& - E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & - 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -! Ufff.... We've done all this!!! - return - end subroutine ebend -!----------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc) - - use comm_calcthet -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.IOUNITS' -!el real(kind=8) :: term1,term2,termm,diffak,ratak,& -!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& -!el delthe0,sig0inv,sigtc,sigsqtc,delthec - integer :: i,j,k - real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc -!el integer :: it -!el common /calcthet/ term1,term2,termm,diffak,ratak,& -!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& -!el delthe0,sig0inv,sigtc,sigsqtc,delthec,it -!el local variables - real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,& - esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd - -! Calculate the contributions to both Gaussian lobes. -! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -! The "polynomial part" of the "standard deviation" of this part of -! the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -! Derivative of the "interior part" of the "standard deviation of the" -! gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -! Set the parameters of both Gaussian lobes of the distribution. -! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -! print *,i,sig,sigtc,sigsqtc -! Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -! Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -! NaNs in taking the logarithm. We extract the largest exponent which is added -! to the energy (this being the log of the distribution) at the end of energy -! term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -! The ratio between the gamma-independent and gamma-dependent lobes of -! the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -! Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -! Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -! Contribution of the bending energy from this theta is just the -log of -! the sum of the contributions from the two lobes and the pre-exponential -! factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -! NOW the derivatives!!! -! 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 & - +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre & - -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ & - aktc*term2)/termexp) - return - end subroutine theteng -#else -!----------------------------------------------------------------------------- - subroutine ebend(etheta) -! -! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -! angles gamma and its derivatives in consecutive thetas and gammas. -! ab initio-derived potentials from -! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.FFIELD' -! include 'COMMON.CONTROL' - real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm - real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle - real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble - logical :: lprn=.false., lprn1=.false. -!el local variables - integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m - real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai - real(kind=8) :: aux,etheta,ccl,ssl,scl,csl - - etheta=0.0D0 - do i=ithet_start,ithet_end - if (itype(i-1).eq.ntyp1) cycle - if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle - if (iabs(itype(i+1)).eq.20) iblock=2 - if (iabs(itype(i+1)).ne.20) iblock=1 - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp((itype(i-1))) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp((itype(i-2))) -! propagation of chirality for glycine type - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres .and. itype(i+1).ne.ntyp1) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp((itype(i))) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,& - " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & - *coskt(k) - if (lprn) & - write (iout,*) "k",k,& - "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),& - " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),& - sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) & - +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) & - +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) & - +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)* & - (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- & - bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)* & - (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- & - ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) - if (lprn) & - write (iout,*) "m",m," k",k," bbthet", & - bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", & - ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", & - ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", & - eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai - enddo - enddo - if (lprn) & - write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & - ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ & - ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & - ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)* & - (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- & - ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & - ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & - ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)* & - (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & - ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & - ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- & - ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet",& - ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),& - ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",& - ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),& - ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),& - " ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m),& - cosph1ph2(k,l)*sinkt(m),& - sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue -! lprn1=.true. - if (lprn1) & - write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') & - i,theta(i)*rad2deg,phii*rad2deg,& - phii1*rad2deg,ethetai -! lprn1=.false. - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & - 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end subroutine ebend -#endif -#ifdef CRYST_SC -!----------------------------------------------------------------------------- - subroutine esc(escloc) -! Calculate the local energy of a side chain and its derivatives in the -! corresponding virtual-bond valence angles THETA and the spherical angles -! ALPHA and OMEGA. -! - use comm_sccalc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.FFIELD' -! include 'COMMON.CONTROL' - real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,& - ddersc0,ddummy,xtemp,temp -!el real(kind=8) :: time11,time12,time112,theti - real(kind=8) :: escloc,delta -!el integer :: it,nlobit -!el common /sccalc/ time11,time12,time112,theti,it,nlobit -!el local variables - integer :: i,k - real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,& - dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd - delta=0.02d0*pi - escloc=0.0D0 -! write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.ntyp1) cycle - if (it.eq.10) goto 1 - nlobit=nlob(iabs(it)) -! print *,'i=',i,' it=',it,' nlobit=',nlobit -! write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),& - escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),& - ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),& - ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,& - dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),& - dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -! write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -! & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -! escloci=esclocbi -! write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),& - escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),& - ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),& - ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,& - dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),& - dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -! write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -! & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -! write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & - 'escloc',i,escloci -! write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & - wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end subroutine esc -!----------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - - use comm_sccalc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.IOUNITS' -!el common /sccalc/ time11,time12,time112,theti,it,nlobit - real(kind=8),dimension(3) :: x,z,dersc,ddersc - real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1) - real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1) - real(kind=8) :: escloci - logical :: mixed -!el local variables - integer :: j,iii,l,k !el,it,nlobit - real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,& -!el time11,time12,time112 -! write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -! Because of periodicity of the dependence of the SC energy in omega we have -! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -! To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -! As in the case of ebend, we want to avoid underflows in exponentiation and -! subsequent NaNs and INFs in energy calculation. -! Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -!d print *,'it=',it,' emin=',emin - -! Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) -#endif -!d print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) & - +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end subroutine enesc -!----------------------------------------------------------------------------- - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - - use comm_sccalc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.IOUNITS' -!el common /sccalc/ time11,time12,time112,theti,it,nlobit - real(kind=8),dimension(3) :: x,z,dersc - real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob) - real(kind=8),dimension(nlobit) :: contr !(maxlob) - real(kind=8) :: escloci,dersc12,emin - logical :: mixed -!el local varables - integer :: j,k,l !el,it,nlobit - real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -! As in the case of ebend, we want to avoid underflows in exponentiation and -! subsequent NaNs and INFs in energy calculation. -! Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -! Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) & - +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end subroutine enesc_bound -#else -!----------------------------------------------------------------------------- - subroutine esc(escloc) -! Calculate the local energy of a side chain and its derivatives in the -! corresponding virtual-bond valence angles THETA and the spherical angles -! ALPHA and OMEGA derived from AM1 all-atom calculations. -! added by Urszula Kozlowska. 07/11/2007 -! - use comm_sccalc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.SCROT' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.FFIELD' -! include 'COMMON.CONTROL' -! include 'COMMON.VECTORS' - real(kind=8),dimension(3) :: x_prime,y_prime,z_prime - real(kind=8),dimension(65) :: x - real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,& - sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt - real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t - real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,& - dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1 -!el local variables - integer :: i,j,k !el,it,nlobit - real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta -!el real(kind=8) :: time11,time12,time112,theti -!el common /sccalc/ time11,time12,time112,theti,it,nlobit - real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,& - pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,& - sumene1x,sumene2x,sumene3x,sumene4x,& - sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,& - cosfac2xx,sinfac2yy -#ifdef DEBUG - real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,& - de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,& - de_dt_num -#endif -! if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres) - - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - if (itype(i).eq.ntyp1) cycle - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=iabs(itype(i)) - if (it.eq.10) goto 1 -! -! Compute the axes of tghe local cartesian coordinates system; store in -! x_prime, y_prime and z_prime -! - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -! write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -! & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) - enddo -! write (2,*) "i",i -! write (2,*) "x_prime",(x_prime(j),j=1,3) -! write (2,*) "y_prime",(y_prime(j),j=1,3) -! write (2,*) "z_prime",(z_prime(j),j=1,3) -! write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -! & " xy",scalar(x_prime(1),y_prime(1)), -! & " xz",scalar(x_prime(1),z_prime(1)), -! & " yy",scalar(y_prime(1),y_prime(1)), -! & " yz",scalar(y_prime(1),z_prime(1)), -! & " zz",scalar(z_prime(1),z_prime(1)) -! -! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -! to local coordinate system. Store in xx, yy, zz. -! - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -! -! Compute the energy of the ith side cbain -! -! write (2,*) "xx",xx," yy",yy," zz",zz - it=iabs(itype(i)) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -!c diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') & - alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,& - xx1,yy1,zz1 -!," --- ", xx_w,yy_w,zz_w -! end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 & - + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy & - + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 & - + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy & - + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 & - +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy & - +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 & - +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx & - +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy & - +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 & - +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy & - +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 & - +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx & - +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy & - +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & - *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & - *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) & - + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -! write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -! & sumene4, -! & dscp1,dscp2,sumene -! sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -! write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) -! & ,zz,xx,yy -!#define DEBUG -#ifdef DEBUG -! -! This section to check the numerical derivatives of the energy of ith side -! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -! #define DEBUG in the code to turn it on. -! - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -! End of diagnostics section. -#endif -! -! Compute the gradient of esc -! -! zz=zz*dsign(1.0,dfloat(itype(i))) - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) & - *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) & - *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 & - +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) & - +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 & - +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) & - +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) & - +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) & - +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i) -#endif -! - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 & - +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) & - +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz & - +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz & - +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) & - +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) & - +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i) -#endif -! - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy & - +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx & - +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) & - +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) & - +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 & - +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy & - +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) & - + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i) -#endif -! - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) & - -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) & - +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i) -#endif -! -! - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* & - vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* & - vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -! write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -! & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -! write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -! & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) & - *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) & - *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)* & - (z_prime(k)-zz*dC_norm(k,i+nres)) -! - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -! write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -! & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -! write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -! & dyy_ci(k)," dzz_ci",dzz_ci(k) -! write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -! & dt_dci(k) -! write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -! & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) & - +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) & - +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) & - +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -! write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -! & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -! to check gradient call subroutine check_grad - - 1 continue - enddo - return - end subroutine esc -!----------------------------------------------------------------------------- - real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2) -! implicit none - real(kind=8),dimension(65) :: x - real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,& - sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 & - + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy & - + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 & - + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy & - + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 & - +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy & - +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 & - +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx & - +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy & - +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 & - +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy & - +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 & - +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx & - +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy & - +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & - *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & - *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) & - + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end function enesc -#endif -!----------------------------------------------------------------------------- - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -! -! This procedure calculates two-body contact function g(rij) and its derivative: -! -! eps0ij ! x < -1 -! g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -! 0 ! x > 1 -! -! where x=(rij-r0ij)/delta -! -! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -! -! implicit none - real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont - real(kind=8) :: x,x2,x4,delta -! delta=0.02D0*r0ij -! delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end subroutine gcont -!----------------------------------------------------------------------------- - subroutine splinthet(theti,delta,ss,ssder) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8) :: theti,delta,ss,ssder - real(kind=8) :: thetup,thetlow - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end subroutine splinthet -!----------------------------------------------------------------------------- - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) -! implicit none - real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim - real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end subroutine spline1 -!----------------------------------------------------------------------------- - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) -! implicit none - real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx - real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end subroutine spline2 -!----------------------------------------------------------------------------- -#ifdef CRYST_TOR -!----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' - real(kind=8) :: etors,edihcnstr - logical :: lprn -!el local variables - integer :: i,j, - real(kind=8) :: phii,fac,etors_ii - -! Set lprn=.true. for debugging - lprn=.false. -! lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 & - .or. itype(i).eq.ntyp1) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -! Proline-Proline pair is a special case... - if (itori.eq.3 .and. itori1.eq.3) then - if (phii.gt.-dwapi3) then - cosphi=dcos(3*phii) - fac=1.0D0/(1.0D0-cosphi) - etorsi=v1(1,3,3)*fac - etorsi=etorsi+etorsi - etors=etors+etorsi-v1(1,3,3) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ & - v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ & - v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & - 'etor',i,etors_ii - if (lprn) & - write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & - restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,& - (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -! write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end subroutine etor -!----------------------------------------------------------------------------- - subroutine etor_d(etors_d) - real(kind=8) :: etors_d - etors_d=0.0d0 - return - end subroutine etor_d -#else -!----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.TORCNSTR' -! include 'COMMON.CONTROL' - real(kind=8) :: etors,edihcnstr - logical :: lprn -!el local variables - integer :: i,j,iblock,itori,itori1 - real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,& - vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom -! Set lprn=.true. for debugging - lprn=.false. -! lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & - .or. itype(i-3).eq.ntyp1 & - .or. itype(i).eq.ntyp1) cycle - etors_ii=0.0D0 - if (iabs(itype(i)).eq.20) then - iblock=2 - else - iblock=1 - endif - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -! Regular cosine and sine terms - do j=1,nterm(itori,itori1,iblock) - v1ij=v1(j,itori,itori1,iblock) - v2ij=v2(j,itori,itori1,iblock) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - if (energy_dec) etors_ii=etors_ii+ & - v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -! Lorentz terms -! v1 -! E = SUM ----------------------------------- - v1 -! [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -! - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1,iblock) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ & - vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -! Subtract the constant term - etors=etors-v0(itori,itori1,iblock) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & - 'etor',i,etors_ii-v0(itori,itori1,iblock) - if (lprn) & - write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & - restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,& - (v1(j,itori,itori1,iblock),j=1,6),& - (v2(j,itori,itori1,iblock),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -! write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -! do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -!d write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -!d & rad2deg*phi0(i), rad2deg*drange(i), -!d & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -!d write (iout,*) 'edihcnstr',edihcnstr - return - end subroutine etor -!----------------------------------------------------------------------------- - subroutine etor_d(etors_d) -! 6/23/01 Compute double torsional energy -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.TORCNSTR' - real(kind=8) :: etors_d,etors_d_ii - logical :: lprn -!el local variables - integer :: i,j,k,l,itori,itori1,itori2,iblock - real(kind=8) :: phii,phii1,gloci1,gloci2,& - v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,& - sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,& - cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2 -! Set lprn=.true. for debugging - lprn=.false. -! lprn=.true. - etors_d=0.0D0 -! write(iout,*) "a tu??" - do i=iphid_start,iphid_end - etors_d_ii=0.0D0 - if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & - .or. itype(i-3).eq.ntyp1 & - .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 - iblock=1 - if (iabs(itype(i+1)).eq.20) iblock=2 - -! Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2,iblock) - v1cij=v1c(1,j,itori,itori1,itori2,iblock) - v1sij=v1s(1,j,itori,itori1,itori2,iblock) - v2cij=v1c(2,j,itori,itori1,itori2,iblock) - v2sij=v1s(2,j,itori,itori1,itori2,iblock) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ & - v2cij*cosphi2+v2sij*sinphi2 - if (energy_dec) etors_d_ii=etors_d_ii+ & - v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2,iblock) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2,iblock) - v2cdij = v2c(l,k,itori,itori1,itori2,iblock) - v1sdij = v2s(k,l,itori,itori1,itori2,iblock) - v2sdij = v2s(l,k,itori,itori1,itori2,iblock) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ & - v1sdij*sinphi1p2+v2sdij*sinphi1m2 - if (energy_dec) etors_d_ii=etors_d_ii+ & - v1cdij*cosphi1p2+v2cdij*cosphi1m2+ & - v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 & - -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 & - -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & - 'etor_d',i,etors_d_ii - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 - enddo - return - end subroutine etor_d -#endif -!----------------------------------------------------------------------------- - subroutine eback_sc_corr(esccor) -! 7/21/2007 Correlations between the backbone-local and side-chain-local -! conformational states; temporarily implemented as differences -! between UNRES torsional potentials (dependent on three types of -! residues) and the torsional potentials dependent on all 20 types -! of residues computed from AM1 energy surfaces of terminally-blocked -! amino-acid residues. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.SCCOR' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.CONTROL' - real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,& - cosphi,sinphi - logical :: lprn - integer :: i,interty,j,isccori,isccori1,intertyp -! Set lprn=.true. for debugging - lprn=.false. -! lprn=.true. -! write (iout,*) "EBACK_SC_COR",itau_start,itau_end - esccor=0.0D0 - do i=itau_start,itau_end - if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle - esccor_ii=0.0D0 - isccori=isccortyp(itype(i-2)) - isccori1=isccortyp(itype(i-1)) - -! write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) - phii=phi(i) - do intertyp=1,3 !intertyp - esccor_ii=0.0D0 -!c Added 09 May 2012 (Adasko) -!c Intertyp means interaction type of backbone mainchain correlation: -! 1 = SC...Ca...Ca...Ca -! 2 = Ca...Ca...Ca...SC -! 3 = SC...Ca...Ca...SCi - gloci=0.0D0 - if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. & - (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. & - (itype(i-1).eq.ntyp1))) & - .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) & - .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) & - .or.(itype(i).eq.ntyp1))) & - .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. & - (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. & - (itype(i-3).eq.ntyp1)))) cycle - if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle - if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) & - cycle - do j=1,nterm_sccor(isccori,isccori1) - v1ij=v1sccor(j,intertyp,isccori,isccori1) - v2ij=v2sccor(j,intertyp,isccori,isccori1) - cosphi=dcos(j*tauangle(intertyp,i)) - sinphi=dsin(j*tauangle(intertyp,i)) - if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') & - 'esccor',i,intertyp,esccor_ii -! write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp - gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci - if (lprn) & - write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & - restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,& - (v1sccor(j,intertyp,isccori,isccori1),j=1,6),& - (v2sccor(j,intertyp,isccori,isccori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo !intertyp - enddo - - return - end subroutine eback_sc_corr -!----------------------------------------------------------------------------- - subroutine multibody(ecorr) -! This subroutine calculates multi-body contributions to energy following -! the idea of Skolnick et al. If side chains I and J make a contact and -! at the same time side chains I+1 and J+1 make a contact, an extra -! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' - real(kind=8),dimension(3) :: gx,gx1 - logical :: lprn - real(kind=8) :: ecorr - integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk -! Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') & - i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - -! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) -! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -!d write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -!d & ' ishift=',ishift -! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -! The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end subroutine multibody -!----------------------------------------------------------------------------- - real(kind=8) function esccorr(i,j,k,l,jj,kk) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' - real(kind=8),dimension(3) :: gx,gx1 - logical :: lprn - integer :: i,j,k,l,jj,kk,m,ll - real(kind=8) :: eij,ekl - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -!d write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -! Calculate the multi-body contribution to energy. -! Calculate multi-body contributions to the gradient. -!d write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -!d & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end function esccorr -!----------------------------------------------------------------------------- - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -! This subroutine calculates multi-body contributions to hydrogen-bonding -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" -! integer :: maxconts !max_cont=maxconts =nres/4 - integer,parameter :: max_dim=26 - integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) -!el real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) -!el common /przechowalnia/ zapas - integer :: status(MPI_STATUS_SIZE) - integer,dimension((nres/4)*2) :: req !maxconts*2 - integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr -#endif -! include 'COMMON.SETUP' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.CONTROL' -! include 'COMMON.LOCAL' - real(kind=8),dimension(3) :: gx,gx1 - real(kind=8) :: time00,ecorr,ecorr5,ecorr6 - logical :: lprn,ldone -!el local variables - integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,& - jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc - -! Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI -! maxconts=nres/4 - if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks)) - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') & - i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& - j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -! write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -! & ntask_cont_to -! Make the list of contacts to send to send to other procesors -! write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end -! call flush(iout) - do i=iturn3_start,iturn3_end -! write (iout,*) "make contact list turn3",i," num_cont", -! & num_cont_hb(i) - call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -! write (iout,*) "make contact list turn4",i," num_cont", -! & num_cont_hb(i) - call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -! write (iout,*) "make contact list longrange",i,ii," num_cont", -! & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -! write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.gt.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,i) - zapas(4,nn,iproc)=ees0p(j,i) - zapas(5,nn,iproc)=ees0m(j,i) - zapas(6,nn,iproc)=gacont_hbr(1,j,i) - zapas(7,nn,iproc)=gacont_hbr(2,j,i) - zapas(8,nn,iproc)=gacont_hbr(3,j,i) - zapas(9,nn,iproc)=gacontm_hb1(1,j,i) - zapas(10,nn,iproc)=gacontm_hb1(2,j,i) - zapas(11,nn,iproc)=gacontm_hb1(3,j,i) - zapas(12,nn,iproc)=gacontp_hb1(1,j,i) - zapas(13,nn,iproc)=gacontp_hb1(2,j,i) - zapas(14,nn,iproc)=gacontp_hb1(3,j,i) - zapas(15,nn,iproc)=gacontm_hb2(1,j,i) - zapas(16,nn,iproc)=gacontm_hb2(2,j,i) - zapas(17,nn,iproc)=gacontm_hb2(3,j,i) - zapas(18,nn,iproc)=gacontp_hb2(1,j,i) - zapas(19,nn,iproc)=gacontp_hb2(2,j,i) - zapas(20,nn,iproc)=gacontp_hb2(3,j,i) - zapas(21,nn,iproc)=gacontm_hb3(1,j,i) - zapas(22,nn,iproc)=gacontm_hb3(2,j,i) - zapas(23,nn,iproc)=gacontm_hb3(3,j,i) - zapas(24,nn,iproc)=gacontp_hb3(1,j,i) - zapas(25,nn,iproc)=gacontp_hb3(2,j,i) - zapas(26,nn,iproc)=gacontp_hb3(3,j,i) - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) & - "Numbers of contacts to be sent to other processors",& - (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc,& - " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -! Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,& - FG_COMM,req(ireq),IERR) - enddo -! write (iout,*) "IRECV ended" -! call flush(iout) -! Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,& - FG_COMM,req(ireq),IERR) - enddo -! write (iout,*) "ISEND ended" -! write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) & - call MPI_Waitall(ireq,req,status_array,ierr) -! write (iout,*) -! & "Numbers of contacts to be received from other processors", -! & (ncont_recv(i),i=1,ntask_cont_from) -! call flush(iout) -! Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -! write (iout,*) "Receiving",nn," contacts from processor",iproc, -! & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,& - MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -! write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -! Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -! write (iout,*) nn," contacts to processor",iproc, -! & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,& - iproc,CorrelType1,FG_COMM,req(ireq),IERR) -! write (iout,*) "ireq,req",ireq,req(ireq) -! do i=1,nn -! write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -! enddo - endif - enddo -! write (iout,*) "number of requests (contacts)",ireq -! write (iout,*) "req",(req(i),i=1,4) -! call flush(iout) - if (ireq.gt.0) & - call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc,& - " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -! Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -! write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -! call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - facont_hb(nnn,ii)=zapas_recv(3,i,iii) - ees0p(nnn,ii)=zapas_recv(4,i,iii) - ees0m(nnn,ii)=zapas_recv(5,i,iii) - gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) - gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) - gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) - gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) - gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) - gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) - gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) - gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) - gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) - gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) - gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) - gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) - gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) - gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) - gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) - gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) - gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) - gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) - gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) - gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) - gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') & - i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& - j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') & - i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& - j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - -! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) -! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) -! Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -! Calculate the local-electrostatic correlation terms - do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,& -! ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1 - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 & - .or. j.lt.0 .and. j1.gt.0) .and. & - (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -! The system gains extra energy. - ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -! Contacts I-J and I-(J+1) occur simultaneously. -! The system loses extra energy. -! ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -! & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -! Contacts I-J and (I+1)-J occur simultaneously. -! The system loses extra energy. -! ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end subroutine multibody_hb -!----------------------------------------------------------------------------- - subroutine add_hb_contact(ii,jj,itask) -! implicit real*8 (a-h,o-z) -! include "DIMENSIONS" -! include "COMMON.IOUNITS" -! include "COMMON.CONTACTS" -! integer,parameter :: maxconts=nres/4 - integer,parameter :: max_dim=26 - real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) -! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) -! common /przechowalnia/ zapas - integer :: i,j,ii,jj,iproc,nn,jjc - integer,dimension(4) :: itask -! write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -! write (iout,*) "i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,ii) - zapas(4,nn,iproc)=ees0p(j,ii) - zapas(5,nn,iproc)=ees0m(j,ii) - zapas(6,nn,iproc)=gacont_hbr(1,j,ii) - zapas(7,nn,iproc)=gacont_hbr(2,j,ii) - zapas(8,nn,iproc)=gacont_hbr(3,j,ii) - zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) - zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) - zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) - zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) - zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) - zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) - zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) - zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) - zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) - zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) - zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) - zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) - zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) - zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) - zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) - zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) - zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) - zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) - exit - endif - enddo - endif - enddo - return - end subroutine add_hb_contact -!----------------------------------------------------------------------------- - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -! This subroutine calculates multi-body contributions to hydrogen-bonding -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer,parameter :: max_dim=70 -#ifdef MPI - include "mpif.h" -! integer :: maxconts !max_cont=maxconts=nres/4 - integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) -! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) -! common /przechowalnia/ zapas - integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),& - status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,& - ierr,iii,nnn -#endif -! include 'COMMON.SETUP' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.CHAIN' -! include 'COMMON.CONTROL' - real(kind=8),dimension(3) :: gx,gx1 - integer,dimension(nres) :: num_cont_hb_old - logical :: lprn,ldone -!EL double precision eello4,eello5,eelo6,eello_turn6 -!EL external eello4,eello5,eello6,eello_turn6 -!el local variables - integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,& - j1,jp1,i1,num_conti1 - real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont - real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 - -! Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI -! maxconts=nres/4 - if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks)) - do i=1,nres - num_cont_hb_old(i)=num_cont_hb(i) - enddo - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') & - i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),& - j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -! write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -! & ntask_cont_to -! Make the list of contacts to send to send to other procesors - do i=iturn3_start,iturn3_end -! write (iout,*) "make contact list turn3",i," num_cont", -! & num_cont_hb(i) - call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -! write (iout,*) "make contact list turn4",i," num_cont", -! & num_cont_hb(i) - call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -! write (iout,*) "make contact list longrange",i,ii," num_cont", -! & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -! write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.ne.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,i) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) - enddo - enddo - enddo - enddo - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) & - "Numbers of contacts to be sent to other processors",& - (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc,& - " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -! Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,& - FG_COMM,req(ireq),IERR) - enddo -! write (iout,*) "IRECV ended" -! call flush(iout) -! Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,& - FG_COMM,req(ireq),IERR) - enddo -! write (iout,*) "ISEND ended" -! write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) & - call MPI_Waitall(ireq,req,status_array,ierr) -! write (iout,*) -! & "Numbers of contacts to be received from other processors", -! & (ncont_recv(i),i=1,ntask_cont_from) -! call flush(iout) -! Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -! write (iout,*) "Receiving",nn," contacts from processor",iproc, -! & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,& - MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -! write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -! Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -! write (iout,*) nn," contacts to processor",iproc, -! & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,& - iproc,CorrelType1,FG_COMM,req(ireq),IERR) -! write (iout,*) "ireq,req",ireq,req(ireq) -! do i=1,nn -! write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -! enddo - endif - enddo -! write (iout,*) "number of requests (contacts)",ireq -! write (iout,*) "req",(req(i),i=1,4) -! call flush(iout) - if (ireq.gt.0) & - call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc,& - " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -! Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -! write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -! call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - d_cont(nnn,ii)=zapas_recv(3,i,iii) - ind=3 - do kk=1,3 - ind=ind+1 - grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') & - i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),& - ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') & - i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),& - ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 - -! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) -! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) -! Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -! Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - enddo - enddo - endif -! Calculate the local-electrostatic correlation terms -! write (iout,*) "gradcorr5 in eello5 before loop" -! do iii=1,nres -! write (iout,'(i5,3f10.5)') -! & iii,(gradcorr5(jjj,iii),jjj=1,3) -! enddo - do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) -! write (iout,*) "corr loop i",i - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -! & ' jj=',jj,' kk=',kk -! if (j1.eq.j+1 .or. j1.eq.j-1) then - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 & - .or. j.lt.0 .and. j1.gt.0) .and. & - (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -! The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr,& - ekont,fprimcont) -!d write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, -!d & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -!d write (iout,*) 'sred_geom=',sred_geom, -!d & ' ekont=',ekont,' fprim=',fprimcont, -!d & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 -!d write (iout,*) "g_contij",g_contij -!d write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) -!d write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) - call calc_eello(i,jp,i+1,jp1,jj,kk) - if (wcorr4.gt.0.0d0) & - ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) - if (energy_dec.and.wcorr4.gt.0.0d0) & - write (iout,'(a6,4i5,0pf7.3)') & - 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) -! write (iout,*) "gradcorr5 before eello5" -! do iii=1,nres -! write (iout,'(i5,3f10.5)') -! & iii,(gradcorr5(jjj,iii),jjj=1,3) -! enddo - if (wcorr5.gt.0.0d0) & - ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) -! write (iout,*) "gradcorr5 after eello5" -! do iii=1,nres -! write (iout,'(i5,3f10.5)') -! & iii,(gradcorr5(jjj,iii),jjj=1,3) -! enddo - if (energy_dec.and.wcorr5.gt.0.0d0) & - write (iout,'(a6,4i5,0pf7.3)') & - 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) -!d write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -!d write(2,*)'ijkl',i,jp,i+1,jp1 - if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 & - .or. wturn6.eq.0.0d0))then -!d write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') & - 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) -!d write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -!d & 'ecorr6=',ecorr6 -!d write (iout,'(4e15.5)') sred_geom, -!d & dabs(eello4(i,jp,i+1,jp1,jj,kk)), -!d & dabs(eello5(i,jp,i+1,jp1,jj,kk)), -!d & dabs(eello6(i,jp,i+1,jp1,jj,kk)) - else if (wturn6.gt.0.0d0 & - .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then -!d write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 - eturn6=eturn6+eello_turn6(i,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') & - 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) -!d write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - endif - enddo ! kk - enddo ! jj - enddo ! i - do i=1,nres - num_cont_hb(i)=num_cont_hb_old(i) - enddo -! write (iout,*) "gradcorr5 in eello5" -! do iii=1,nres -! write (iout,'(i5,3f10.5)') -! & iii,(gradcorr5(jjj,iii),jjj=1,3) -! enddo - return - end subroutine multibody_eello -!----------------------------------------------------------------------------- - subroutine add_hb_contact_eello(ii,jj,itask) -! implicit real*8 (a-h,o-z) -! include "DIMENSIONS" -! include "COMMON.IOUNITS" -! include "COMMON.CONTACTS" -! integer,parameter :: maxconts=nres/4 - integer,parameter :: max_dim=70 - real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) -! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) -! common /przechowalnia/ zapas - - integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm - integer,dimension(4) ::itask -! write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -! write (iout,*) "send turns i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,ii) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) - enddo - enddo - enddo - enddo - exit - endif - enddo - endif - enddo - return - end subroutine add_hb_contact_eello -!----------------------------------------------------------------------------- - real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' - real(kind=8),dimension(3) :: gx,gx1 - logical :: lprn -!el local variables - integer :: i,j,k,l,jj,kk,ll - real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,& - ees0mkl,ees,coeffpees0pij,coeffmees0mij,& - coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl - - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -!d ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -! Following 4 lines for diagnostics. -!d ees0pkl=0.0D0 -!d ees0pij=1.0D0 -!d ees0mkl=0.0D0 -!d ees0mij=1.0D0 -! write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') -! & 'Contacts ',i,j, -! & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l -! & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, -! & 'gradcorr_long' -! Calculate the multi-body contribution to energy. -! ecorr=ecorr+ekont*ees -! Calculate multi-body contributions to the gradient. - coeffpees0pij=coeffp*ees0pij - coeffmees0mij=coeffm*ees0mij - coeffpees0pkl=coeffp*ees0pkl - coeffmees0mkl=coeffm*ees0mkl - do ll=1,3 -!grad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi - -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ & - coeffmees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi - -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ & - coeffmees0mkl*gacontm_hb2(ll,jj,i)) -!grad ghalfk=ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk - -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+& - coeffmees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk - -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ & - coeffmees0mij*gacontm_hb2(ll,kk,k)) - gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- & - ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ & - coeffmees0mkl*gacontm_hb3(ll,jj,i)) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij - gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- & - ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ & - coeffmees0mij*gacontm_hb3(ll,kk,k)) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl -! write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl - enddo -! write (iout,*) -!grad do m=i+1,j-1 -!grad do ll=1,3 -!grad gradcorr(ll,m)=gradcorr(ll,m)+ -!grad & ees*ekl*gacont_hbr(ll,jj,i)- -!grad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ -!grad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) -!grad enddo -!grad enddo -!grad do m=k+1,l-1 -!grad do ll=1,3 -!grad gradcorr(ll,m)=gradcorr(ll,m)+ -!grad & ees*eij*gacont_hbr(ll,kk,k)- -!grad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ -!grad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) -!grad enddo -!grad enddo -! write (iout,*) "ehbcorr",ekont*ees - ehbcorr=ekont*ees - return - end function ehbcorr -#ifdef MOMENT -!----------------------------------------------------------------------------- - subroutine dipole(i,j,jj) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8),dimension(2,2) :: dipi,dipj,auxmat - real(kind=8),dimension(2) :: dipderi,dipderj,auxvec - integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1 - - allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres)) - allocate(dipderx(3,5,4,maxconts,nres)) -! - - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),& - auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end subroutine dipole -#endif -!----------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -! -! This subroutine computes matrices and vectors needed to calculate -! the fourth-, fifth-, and sixth-order local-electrostatic terms. -! - use comm_kut -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.FFIELD' - real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat - real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder - integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,& - itj1 -!el logical :: lprn -!el common /kutas/ lprn -!d write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -!d & ' jj=',jj,' kk=',kk -!d if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return -!d write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) -!d write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),& - aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),& - aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -! parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -! A1 kernel(j+1) A2T -!d do iii=1,2 -!d write (iout,'(3f10.5,5x,3f10.5)') -!d & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -!d enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),& - AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -! Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),& - AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),& - Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),& - ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),& - DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),& - ADtEA1derx(1,1,1,1,1,1)) - ENDIF -! End 6-th order cumulants -!d lprn=.false. -!d if (lprn) then -!d write (2,*) 'In calc_eello6' -!d do iii=1,2 -!d write (2,*) 'iii=',iii -!d do kkk=1,5 -!d write (2,*) 'kkk=',kkk -!d do jjj=1,2 -!d write (2,'(3(2f10.5),5x)') -!d & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -!d enddo -!d enddo -!d enddo -!d endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),& - EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -! A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& - a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),& - AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -! Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& - a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),& - AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& - a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),& - Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),& - ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),& - a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),& - DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),& - ADtEA1derx(1,1,1,1,1,2)) - ENDIF -! End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& - EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -! AEAb1 and AEAb2 -! Calculate the vectors and their derivatives in virtual-bond dihedral angles. -! They are needed only when the fifth- or the sixth-order cumulants are -! indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -! Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),& - AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),& - AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),& - AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),& - AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),& - AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),& - AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),& - AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),& - AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -! End vectors - else -! Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -! A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),& - AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -! Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. & - j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),& - AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),& - Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),& - ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),& - aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),& - DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),& - ADtEA1derx(1,1,1,1,1,1)) - ENDIF -! End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),& - EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -! A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& - a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),& - AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -! Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. & - j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& - a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),& - AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& - a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),& - Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),& - ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),& - a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),& - DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),& - ADtEA1derx(1,1,1,1,1,2)) - ENDIF -! End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& - EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -! AEAb1 and AEAb2 -! Calculate the vectors and their derivatives in virtual-bond dihedral angles. -! They are needed only when the fifth- or the sixth-order cumulants are -! indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. & - (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -! Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),& - AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),& - AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),& - AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),& - AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),& - AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),& - AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),& - AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),& - AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -! End vectors - endif - return - end subroutine calc_eello -!----------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx) - use comm_kut - implicit none - integer :: nderg - logical :: transp - real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA - real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx - real(kind=8),dimension(2,2,3,5,2) :: AKAderx - real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg - integer :: iii,kkk,lll - integer :: jjj,mmm -!el logical :: lprn -!el common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,& - AKAderg(1,1,iii)) - enddo -!d if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -!d if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),& - KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -!d if (lprn) then -!d write (2,*) 'lll=',lll -!d write (2,*) 'iii=1' -!d do jjj=1,2 -!d write (2,'(3(2f10.5),5x)') -!d & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -!d enddo -!d endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),& - KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -!d if (lprn) then -!d write (2,*) 'lll=',lll -!d write (2,*) 'iii=2' -!d do jjj=1,2 -!d write (2,'(3(2f10.5),5x)') -!d & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -!d enddo -!d endif - enddo - enddo - return - end subroutine kernel -!----------------------------------------------------------------------------- - real(kind=8) function eello4(i,j,k,l,jj,kk) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8),dimension(2,2) :: pizda - real(kind=8),dimension(3) :: ggg1,ggg2 - real(kind=8) :: eel4,glongij,glongkl - integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll -!d if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -!d eello4=0.0d0 -!d return -!d endif -!d print *,'eello4:',i,j,k,l,jj,kk -!d write (2,*) 'i',i,' j',j,' k',k,' l',l -!d call checkint4(i,j,k,l,jj,kk,eel4_num) -!old eij=facont_hb(jj,i) -!old ekl=facont_hb(kk,k) -!old ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -!d eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) & - -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) & - -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) & - -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) & - -EAEAderx(2,2,lll,kkk,iii,1) -!d derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -!d gcorr_loc(l-1)=0.0d0 -!d gcorr_loc(j-1)=0.0d0 -!d gcorr_loc(k-1)=0.0d0 -!d eel4=1.0d0 -!d write (iout,*)'Contacts have occurred for peptide groups', -!d & i,j,' fcont:',eij,' eij',' and ',k,l, -!d & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -!grad ggg1(ll)=eel4*g_contij(ll,1) -!grad ggg2(ll)=eel4*g_contij(ll,2) - glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) - glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) -!grad ghalf=0.5d0*ggg1(ll) - gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij -!grad ghalf=0.5d0*ggg2(ll) - gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl - enddo -!grad do m=i+1,j-1 -!grad do ll=1,3 -!grad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) -!grad enddo -!grad enddo -!grad do m=k+1,l-1 -!grad do ll=1,3 -!grad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) -!grad enddo -!grad enddo -!grad do m=i+2,j2 -!grad do ll=1,3 -!grad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) -!grad enddo -!grad enddo -!grad do m=k+2,l2 -!grad do ll=1,3 -!grad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) -!grad enddo -!grad enddo -!d do iii=1,nres-3 -!d write (2,*) iii,gcorr_loc(iii) -!d enddo - eello4=ekont*eel4 -!d write (2,*) 'ekont',ekont -!d write (iout,*) 'eello4',ekont*eel4 - return - end function eello4 -!----------------------------------------------------------------------------- - real(kind=8) function eello5(i,j,k,l,jj,kk) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 - real(kind=8),dimension(2) :: vv - real(kind=8),dimension(3) :: ggg1,ggg2 - real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5 - real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf - integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! C -! Parallel chains C -! C -! o o o o C -! /l\ / \ \ / \ / \ / C -! / \ / \ \ / \ / \ / C -! j| o |l1 | o | o| o | | o |o C -! \ |/k\| |/ \| / |/ \| |/ \| C -! \i/ \ / \ / / \ / \ C -! o k1 o C -! (I) (II) (III) (IV) C -! C -! eello5_1 eello5_2 eello5_3 eello5_4 C -! C -! Antiparallel chains C -! C -! o o o o C -! /j\ / \ \ / \ / \ / C -! / \ / \ \ / \ / \ / C -! j1| o |l | o | o| o | | o |o C -! \ |/k\| |/ \| / |/ \| |/ \| C -! \i/ \ / \ / / \ / \ C -! o k1 o C -! (I) (II) (III) (IV) C -! C -! eello5_1 eello5_2 eello5_3 eello5_4 C -! C -! o denotes a local interaction, vertical lines an electrostatic interaction. C -! C -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!d if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -!d eello5=0.0d0 -!d return -!d endif -!d write (iout,*) -!d & 'EELLO5: Contacts have occurred for peptide groups',i,j, -!d & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -!d call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -!d & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -!d eij=facont_hb(jj,i) -!d ekl=facont_hb(kk,k) -!d ekont=eij*ekl -!d write (iout,*)'Contacts have occurred for peptide groups', -!d & i,j,' fcont:',eij,' eij',' and ',k,l -!d goto 1111 -! Contribution from the graph I. -!d write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -!d write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -! Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) & - +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) & - +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) & - +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) & - +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) & - +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -! Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),& - pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) & - +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -! goto 1112 -!1111 continue -! Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) & - -0.5d0*scalar2(vv(1),Ctobr(1,k)) -! Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) & - -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) & - +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) & - -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) & - +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) & - -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -! Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),& - pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) & - +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) & - -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -!d goto 1112 -!d1111 continue - if (l.eq.j+1) then -!d goto 1110 -! Parallel orientation -! Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -! Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) & - +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) & - +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) & - +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) & - +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -! Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),& - pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) & - +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -!d goto 1112 -! Contribution from graph IV -!d1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) & - -0.5d0*scalar2(vv(1),Ctobr(1,l)) -! Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) & - -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) & - +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) & - -0.5d0*scalar2(vv(1),Ctobr(1,l))) -! Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& - pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) & - +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) & - -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - else -! Antiparallel orientation -! Contribution from graph III -! goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -! Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) & - +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) & - +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) & - +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) & - +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -! Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),& - pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) & - +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) & - +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -!d goto 1112 -! Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) & - -0.5d0*scalar2(vv(1),Ctobr(1,j)) -! Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) & - -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) & - +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) & - -0.5d0*scalar2(vv(1),Ctobr(1,j))) -! Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),& - pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) & - +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) & - -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -!d if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -!d write (2,*) 'ijkl',i,j,k,l -!d write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -!d & ' eello5_3',eello5_3,' eello5_4',eello5_4 -!d endif -!d write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -!d write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -!d write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -!d write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -!d eij=1.0d0 -!d ekl=1.0d0 -!d ekont=1.0d0 -!d write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont -! 2/11/08 AL Gradients over DC's connecting interacting sites will be -! summed up outside the subrouine as for the other subroutines -! handling long-range interactions. The old code is commented out -! with "cgrad" to keep track of changes. - do ll=1,3 -!grad ggg1(ll)=eel5*g_contij(ll,1) -!grad ggg2(ll)=eel5*g_contij(ll,2) - gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) -! write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') -! & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), -! & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), -! & derx(ll,4,2),derx(ll,5,2)," ekont",ekont -! write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') -! & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), -! & gradcorr5ij, -! & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl -!old ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) -!grad ghalf=0.5d0*ggg1(ll) -!d ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) - gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij - gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij -!old ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) -!grad ghalf=0.5d0*ggg2(ll) - ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -!d goto 1112 -!grad do m=i+1,j-1 -!grad do ll=1,3 -!old gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) -!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) -!grad enddo -!grad enddo -!grad do m=k+1,l-1 -!grad do ll=1,3 -!old gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) -!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) -!grad enddo -!grad enddo -!1112 continue -!grad do m=i+2,j2 -!grad do ll=1,3 -!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) -!grad enddo -!grad enddo -!grad do m=k+2,l2 -!grad do ll=1,3 -!grad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) -!grad enddo -!grad enddo -!d do iii=1,nres-3 -!d write (2,*) iii,g_corr5_loc(iii) -!d enddo - eello5=ekont*eel5 -!d write (2,*) 'ekont',ekont -!d write (iout,*) 'eello5',ekont*eel5 - return - end function eello5 -!----------------------------------------------------------------------------- - real(kind=8) function eello6(i,j,k,l,jj,kk) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.FFIELD' - real(kind=8),dimension(3) :: ggg1,ggg2 - real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,& - eello6_6,eel6 - real(kind=8) :: gradcorr6ij,gradcorr6kl - integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll -!d if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -!d eello6=0.0d0 -!d return -!d endif -!d write (iout,*) -!d & 'EELLO6: Contacts have occurred for peptide groups',i,j, -!d & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -!d call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -!d & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -!d eij=facont_hb(jj,i) -!d ekl=facont_hb(kk,k) -!d ekont=eij*ekl -!d eij=1.0d0 -!d ekl=1.0d0 -!d ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -! If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -!d write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num -!d write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num -!d write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num -!d write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num -!d write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num -!d write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num -!d goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -!grad ggg1(ll)=eel6*g_contij(ll,1) -!grad ggg2(ll)=eel6*g_contij(ll,2) -!old ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) -!grad ghalf=0.5d0*ggg1(ll) -!d ghalf=0.0d0 - gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) - gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij - gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij -!grad ghalf=0.5d0*ggg2(ll) -!old ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -!d ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl - gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl - enddo -!d goto 1112 -!grad do m=i+1,j-1 -!grad do ll=1,3 -!old gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) -!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) -!grad enddo -!grad enddo -!grad do m=k+1,l-1 -!grad do ll=1,3 -!old gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) -!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) -!grad enddo -!grad enddo -!grad1112 continue -!grad do m=i+2,j2 -!grad do ll=1,3 -!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) -!grad enddo -!grad enddo -!grad do m=k+2,l2 -!grad do ll=1,3 -!grad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) -!grad enddo -!grad enddo -!d do iii=1,nres-3 -!d write (2,*) iii,g_corr6_loc(iii) -!d enddo - eello6=ekont*eel6 -!d write (2,*) 'ekont',ekont -!d write (iout,*) 'eello6',ekont*eel6 - return - end function eello6 -!----------------------------------------------------------------------------- - real(kind=8) function eello6_graph1(i,j,k,l,imat,swap) - use comm_kut -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8),dimension(2) :: vv,vv1 - real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1 - logical :: swap -!el logical :: lprn -!el common /kutas/ lprn - integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind - real(kind=8) :: s1,s2,s3,s4,s5 -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! C -! Parallel Antiparallel C -! C -! o o C -! /l\ /j\ C -! / \ / \ C -! /| o | | o |\ C -! \ j|/k\| / \ |/k\|l / C -! \ / \ / \ / \ / C -! o o o o C -! i i C -! C -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -!d write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) & - -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) & - -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) & - +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) & - +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) & - +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) & - +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) & - -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) & - +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) & - +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) & - +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) & - -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) & - +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) & - +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) & - +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) & - +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) & - +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),& - pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) & - -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) & - +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end function eello6_graph1 -!----------------------------------------------------------------------------- - real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap) - use comm_kut -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - logical :: swap - real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2 - real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 -!el logical :: lprn -!el common /kutas/ lprn - integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm - real(kind=8) :: s2,s3,s4 -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! C -! Parallel Antiparallel C -! C -! o o C -! \ /l\ /j\ / C -! \ / \ / \ / C -! o| o | | o |o C -! \ j|/k\| \ |/k\|l C -! \ / \ \ / \ C -! o o C -! i i C -! C -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!d write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -! AL 7/4/01 s1 would occur in the sixth-order moment, -! but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -!d write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -! eello6_graph2=-s3 -! Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - s1=dipderg(1,jj,i)*dip(1,kk,k) -#endif - s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif -! g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 - endif -! Derivatives in gamma(k-1) -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif -! g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 -! Derivatives in gamma(j-1) or gamma(l-1) - if (j.gt.1) then -#ifdef MOMENT - s1=dipderg(3,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) - call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - endif -#endif - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) -! g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 - endif -! Derivatives in gamma(l-1) or gamma(j-1) - if (l.gt.1) then -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(3,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - endif -#endif - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) -! g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 - endif -! Cartesian derivatives. - if (lprn) then - write (2,*) 'In eello6_graph2' - do iii=1,2 - write (2,*) 'iii=',iii - do kkk=1,5 - write (2,*) 'kkk=',kkk - do jjj=1,2 - write (2,'(3(2f10.5),5x)') & - ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) - enddo - enddo - enddo - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) - else - s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) - endif -#endif - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),& - auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),& - auxvec(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),& - pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -!d write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - enddo - enddo - enddo - return - end function eello6_graph2 -!----------------------------------------------------------------------------- - real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8),dimension(2) :: vv,auxvec - real(kind=8),dimension(2,2) :: pizda,auxmat - logical :: swap - integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1 - real(kind=8) :: s1,s2,s3,s4 -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! C -! Parallel Antiparallel C -! C -! o o C -! /l\ / \ /j\ C -! / \ / \ / \ C -! /| o |o o| o |\ C -! j|/k\| / |/k\|l / C -! / \ / / \ / C -! / o / o C -! i i C -! C -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! -! 4/7/01 AL Component s1 was removed, because it pertains to the respective -! energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -!d write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, -!d & "sum",-(s2+s3+s4) -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -! eello6_graph3=-s4 -! Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -! Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -! Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),& - auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),& - auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),& - pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -! derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end function eello6_graph3 -!----------------------------------------------------------------------------- - real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.FFIELD' - real(kind=8),dimension(2) :: vv,auxvec,auxvec1 - real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 - logical :: swap - integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,& - iii,kkk,lll - real(kind=8) :: s1,s2,s3,s4 -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! C -! Parallel Antiparallel C -! C -! o o C -! /l\ / \ /j\ C -! / \ / \ / \ C -! /| o |o o| o |\ C -! \ j|/k\| \ |/k\|l C -! \ / \ \ / \ C -! o \ o \ C -! i i C -! C -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! -! 4/7/01 AL Component s1 was removed, because it pertains to the respective -! energy moment and not to the cluster cumulant. -!d write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -!d write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -!d write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -!d & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -!d write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif -! Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -!d write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -! Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -! Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -! Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),& - auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),& - b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),& - b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),& - pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) & - -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) & - -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end function eello6_graph4 -!----------------------------------------------------------------------------- - real(kind=8) function eello_turn6(i,jj,kk) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec - real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp - real(kind=8),dimension(3) :: ggg1,ggg2 - real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd - real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd -! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -! the respective energy moment and not to the cluster cumulant. -!el local variables - integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll - integer :: j1,j2,l1,l2,ll - real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6 - real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -! - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -!d write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -!d write (2,*) 'i',i,' k',k,' j',j,' l',l -!d if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -!d eello6=0.0d0 -!d return -!d endif -!d write (iout,*) -!d & 'EELLO6: Contacts have occurred for peptide groups',i,j, -!d & ' and',k,l -!d call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -!d eij=1.0d0 -!d ekl=1.0d0 -!d ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -!d eello6_5=0.0d0 -!d write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -! write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -! s1=0.0d0 -! s2=0.0d0 -! s8=0.0d0 -! s12=0.0d0 -! s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) -! Derivatives in gamma(i+2) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -! s1d=0.0d0 -! s2d=0.0d0 -! s8d=0.0d0 -! s12d=0.0d0 -! s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -! Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -! s1d=0.0d0 -! s2d=0.0d0 -! s8d=0.0d0 -! s12d=0.0d0 -! s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) & - -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) & - -0.5d0*ekont*(s2d+s12d) -#endif -! Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -! s1d=0.0d0 -! s2d=0.0d0 -! s8d=0.0d0 -! s12d=0.0d0 -! s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -! Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -! s1d=0.0d0 -! s2d=0.0d0 -! s8d=0.0d0 -! s12d=0.0d0 -! s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) & - -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) & - -0.5d0*ekont*(s2d+s12d) -#endif -! Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),& - vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* & - scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),& - auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -! s1d=0.0d0 -! s2d=0.0d0 -! s8d=0.0d0 -! s12d=0.0d0 -! s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) & - - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) & - - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) & - - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) & - - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),& - achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),& - vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -!d write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -!d & 16*eel_turn6_num -!d goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -!grad ggg1(ll)=eel_turn6*g_contij(ll,1) -!grad ggg2(ll)=eel_turn6*g_contij(ll,2) -!grad ghalf=0.5d0*ggg1(ll) -!d ghalf=0.0d0 - gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) - gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) - gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf - +ekont*derx_turn(ll,2,1) - gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) - gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf - +ekont*derx_turn(ll,4,1) - gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) - gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij - gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij -!grad ghalf=0.5d0*ggg2(ll) -!d ghalf=0.0d0 - gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf - +ekont*derx_turn(ll,2,2) - gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) - gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf - +ekont*derx_turn(ll,4,2) - gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) - gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl - gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl - enddo -!d goto 1112 -!grad do m=i+1,j-1 -!grad do ll=1,3 -!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) -!grad enddo -!grad enddo -!grad do m=k+1,l-1 -!grad do ll=1,3 -!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) -!grad enddo -!grad enddo -!grad1112 continue -!grad do m=i+2,j2 -!grad do ll=1,3 -!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) -!grad enddo -!grad enddo -!grad do m=k+2,l2 -!grad do ll=1,3 -!grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) -!grad enddo -!grad enddo -!d do iii=1,nres-3 -!d write (2,*) iii,g_corr6_loc(iii) -!d enddo - eello_turn6=ekont*eel_turn6 -!d write (2,*) 'ekont',ekont -!d write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end function eello_turn6 -!----------------------------------------------------------------------------- - subroutine MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -!DEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - real(kind=8),dimension(2) :: V1,V2 - real(kind=8),dimension(2,2) :: A1 - real(kind=8) :: vaux1,vaux2 -! DO 1 I=1,2 -! VI=0.0 -! DO 3 K=1,2 -! 3 VI=VI+A1(I,K)*V1(K) -! Vaux(I)=VI -! 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - end subroutine MATVEC2 -!----------------------------------------------------------------------------- - subroutine MATMAT2(A1,A2,A3) -#ifndef OSF -!DEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - real(kind=8),dimension(2,2) :: A1,A2,A3 - real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22 -! DIMENSION AI3(2,2) -! DO J=1,2 -! A3IJ=0.0 -! DO K=1,2 -! A3IJ=A3IJ+A1(I,K)*A2(K,J) -! enddo -! A3(I,J)=A3IJ -! enddo -! enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - end subroutine MATMAT2 -!----------------------------------------------------------------------------- - real(kind=8) function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - real(kind=8),dimension(2) :: u,v - real(kind=8) :: sc - integer :: i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end function scalar2 -!----------------------------------------------------------------------------- - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -!DEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - real(kind=8),dimension(2,2) :: a,at - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end subroutine transpose2 -!----------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer :: n,i,j - real(kind=8),dimension(n,n) :: a,at - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end subroutine transpose -!----------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -!DEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer :: i,j - real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod - logical :: transp -!rc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -!rc call transpose2(kk(1,1),auxmat(1,1)) -!rc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -!rc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) & - +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) & - +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) & - +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) & - +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -!rc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -!rc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) & - +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) & - +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) & - +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) & - +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -! call transpose2(a2(1,1),a2t(1,1)) - -!rc print *,transp -!rc print *,((prod_(i,j),i=1,2),j=1,2) -!rc print *,((prod(i,j),i=1,2),j=1,2) - - return - end subroutine prodmat3 -!----------------------------------------------------------------------------- -! energy_p_new_barrier.F -!----------------------------------------------------------------------------- - subroutine sum_gradient -! implicit real*8 (a-h,o-z) - use io_base, only: pdbout -! include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' -#endif - real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,& - gloc_scbuf !(3,maxres) - - real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres) -!#endif -!el local variables - integer :: i,j,k,ierror,ierr - real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,& - gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,& - gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,& - gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,& - gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,& - gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,& - gsccorr_max,gsccorrx_max,time00 - -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.CONTROL' -! include 'COMMON.TIME1' -! include 'COMMON.MAXGRAD' -! include 'COMMON.SCCOR' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI - gradbufc=0.0d0 - gradbufx=0.0d0 - gradbufc_sum=0.0d0 - gloc_scbuf=0.0d0 - glocbuf=0.0d0 -! FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) & - call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -! -! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -! in virtual-bond-vector coordinates -! -#ifdef DEBUG -! write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -! do i=1,nres-1 -! write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -! & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -! enddo -! write (iout,*) "gel_loc_tur3 gel_loc_turn4" -! do i=1,nres-1 -! write (iout,'(i5,3f10.5,2x,f10.5)') -! & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -! enddo - write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),& - (gvdwc_scpp(j,i),j=1,3) - enddo - write (iout,*) "gelc_long gvdwpp gel_loc_long" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),& - (gelc_loc_long(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef SPLITELE - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ & - wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ & - welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ & - wel_loc*gel_loc_long(j,i)+ & - wcorr*gradcorr_long(j,i)+ & - wcorr5*gradcorr5_long(j,i)+ & - wcorr6*gradcorr6_long(j,i)+ & - wturn6*gcorr6_turn_long(j,i)+ & - wstrain*ghpbc(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ & - wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ & - welec*gelc_long(j,i)+ & - wbond*gradb(j,i)+ & - wel_loc*gel_loc_long(j,i)+ & - wcorr*gradcorr_long(j,i)+ & - wcorr5*gradcorr5_long(j,i)+ & - wcorr6*gradcorr6_long(j,i)+ & - wturn6*gcorr6_turn_long(j,i)+ & - wstrain*ghpbc(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - enddo - enddo -! call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, -! & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) -! time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG -! write (iout,*) "gradbufc_sum after allreduce" -! do i=1,nres -! write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) -! enddo -! call flush(iout) -#endif -#ifdef TIMING -! time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo -#ifdef DEBUG - write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end - write (iout,*) (i," jgrad_start",jgrad_start(i),& - " jgrad_end ",jgrad_end(i),& - i=igrad_start,igrad_end) -#endif -! -! Obsolete and inefficient code; we can make the effort O(n) and, therefore, -! do not parallelize this part. -! -! do i=igrad_start,igrad_end -! do j=jgrad_start(i),jgrad_end(i) -! do k=1,3 -! gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) -! enddo -! enddo -! enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - else -#endif -!el#define DEBUG -#ifdef DEBUG - write (iout,*) "gradbufc" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif -!el#undef DEBUG - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - gradbufc(j,i)=0.0d0 - enddo - enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -! do i=nnt,nres-1 -! do k=1,3 -! gradbufc(k,i)=0.0d0 -! enddo -! do j=i+1,nres -! do k=1,3 -! gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) -! enddo -! enddo -! enddo -!el#define DEBUG -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif -!el#undef DEBUG -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo -!el---------------- -!el if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2) -!el if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2) -!el----------------- - do i=1,nct - do j=1,3 -#ifdef SPLITELE - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ & - wel_loc*gel_loc(j,i)+ & - 0.5d0*(wscp*gvdwc_scpp(j,i)+ & - welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ & - wel_loc*gel_loc_long(j,i)+ & - wcorr*gradcorr_long(j,i)+ & - wcorr5*gradcorr5_long(j,i)+ & - wcorr6*gradcorr6_long(j,i)+ & - wturn6*gcorr6_turn_long(j,i))+ & - wbond*gradb(j,i)+ & - wcorr*gradcorr(j,i)+ & - wturn3*gcorr3_turn(j,i)+ & - wturn4*gcorr4_turn(j,i)+ & - wcorr5*gradcorr5(j,i)+ & - wcorr6*gradcorr6(j,i)+ & - wturn6*gcorr6_turn(j,i)+ & - wsccor*gsccorc(j,i) & - +wscloc*gscloc(j,i) -#else - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ & - wel_loc*gel_loc(j,i)+ & - 0.5d0*(wscp*gvdwc_scpp(j,i)+ & - welec*gelc_long(j,i)+ & - wel_loc*gel_loc_long(j,i)+ & -!el wcorr*gcorr_long(j,i)+ & !el gcorr_long- brak deklaracji - wcorr5*gradcorr5_long(j,i)+ & - wcorr6*gradcorr6_long(j,i)+ & - wturn6*gcorr6_turn_long(j,i))+ & - wbond*gradb(j,i)+ & - wcorr*gradcorr(j,i)+ & - wturn3*gcorr3_turn(j,i)+ & - wturn4*gcorr4_turn(j,i)+ & - wcorr5*gradcorr5(j,i)+ & - wcorr6*gradcorr6(j,i)+ & - wturn6*gcorr6_turn(j,i)+ & - wsccor*gsccorc(j,i) & - +wscloc*gscloc(j,i) -#endif - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ & - wbond*gradbx(j,i)+ & - wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ & - wsccor*gsccorx(j,i) & - +wscloc*gsclocx(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) & - +wcorr5*g_corr5_loc(i) & - +wcorr6*g_corr6_loc(i) & - +wturn4*gel_loc_turn4(i) & - +wturn3*gel_loc_turn3(i) & - +wturn6*gel_loc_turn6(i) & - +wel_loc*gel_loc_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo -!#define DEBUG -#ifdef DEBUG - write (iout,*) "gloc_sc before reduce" - do i=1,nres - do j=1,1 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif -!#undef DEBUG - do i=1,nres - do j=1,3 - gloc_scbuf(j,i)=gloc_sc(j,i,icg) - enddo - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,& - MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,& - MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,& - MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 - call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,& - MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -!#define DEBUG -#ifdef DEBUG - write (iout,*) "gloc_sc after reduce" - do i=1,nres - do j=1,1 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif -!#undef DEBUG -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -! -! Compute the maximum elements of the gradient -! - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) & - gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),& - gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) & - gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),& - gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) & - gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) & - gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),& - gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) & - gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) & - gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,& - gelc_max,gvdwpp_max,gradb_max,ghpbc_max,& - gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,& - gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,& - gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,& - gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),& - gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -!el#define DEBUG -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -!el#undef DEBUG -#ifdef TIMING - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#endif - return - end subroutine sum_gradient -!----------------------------------------------------------------------------- - subroutine sc_grad -! implicit real*8 (a-h,o-z) - use calc_data -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.CALC' -! include 'COMMON.IOUNITS' - real(kind=8), dimension(3) :: dcosom1,dcosom2 - - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & - -2.0D0*alf12*eps3der+sigder*sigsq_om12 -! diagnostics only -! eom1=0.0d0 -! eom2=0.0d0 -! eom12=evdwij*eps1_om12 -! end diagnostics -! write (iout,*) "eps2der",eps2der," eps3der",eps3der,& -! " sigder",sigder -! write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 -! write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - enddo -! write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) & - +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & - +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - gvdwx(k,j)=gvdwx(k,j)+gg(k) & - +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & - +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv -! write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & -! +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv -! write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & -! +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -! -! Calculate the components of the gradient in DC and X -! -!grad do k=i,j-1 -!grad do l=1,3 -!grad gvdwc(l,k)=gvdwc(l,k)+gg(l) -!grad enddo -!grad enddo - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - return - end subroutine sc_grad -#ifdef CRYST_THETA -!----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - - use comm_calcthet -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.IOUNITS' -!el real(kind=8) :: term1,term2,termm,diffak,ratak,& -!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& -!el delthe0,sig0inv,sigtc,sigsqtc,delthec, - real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t - real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40 -!el integer :: it -!el common /calcthet/ term1,term2,termm,diffak,ratak,& -!el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& -!el delthe0,sig0inv,sigtc,sigsqtc,delthec,it -!el local variables - - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -! "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 & - -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 & - *(-t12*t9-ak*sig0inv*t27) - return - end subroutine mixder -#endif -!----------------------------------------------------------------------------- -! cartder.F -!----------------------------------------------------------------------------- - subroutine cartder -!----------------------------------------------------------------------------- -! This subroutine calculates the derivatives of the consecutive virtual -! bond vectors and the SC vectors in the virtual-bond angles theta and -! virtual-torsional angles phi, as well as the derivatives of SC vectors -! in the angles alpha and omega, describing the location of a side chain -! in its local coordinate system. -! -! The derivatives are stored in the following arrays: -! -! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. -! The structure is as follows: -! -! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 -! dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) -! . . . . . . . . . . . . . . . . . . -! dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) -! . -! . -! . -! dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) -! -! DXDV - the derivatives of the side-chain vectors in theta and phi. -! The structure is same as above. -! -! DCDS - the derivatives of the side chain vectors in the local spherical -! andgles alph and omega: -! -! dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) -! dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) -! . -! . -! . -! dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) -! -! Version of March '95, based on an early version of November '91. -! -!********************************************************************** -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' - real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres) - real(kind=8),dimension(3,3) :: dp,temp -!el real(kind=8) :: fromto(3,3,maxdim) !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) - real(kind=8),dimension(3) :: xx,xx1 -!el local variables - integer :: i,k,l,j,m,ind,ind1,jjj - real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,& - tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,& - sint2,xp,yp,xxp,yyp,zzp,dj - -! common /przechowalnia/ fromto - if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim)) -! get the position of the jth ijth fragment of the chain coordinate system -! in the fromto array. -! indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -! -! maxdim=(nres-1)*(nres-2)/2 -! allocate(dcdv(6,maxdim),dxds(6,nres)) -! calculate the derivatives of transformation matrix elements in theta -! - -!el call flush(iout) !el - do i=1,nres-2 - rdt(1,1,i)=-rt(1,2,i) - rdt(1,2,i)= rt(1,1,i) - rdt(1,3,i)= 0.0d0 - rdt(2,1,i)=-rt(2,2,i) - rdt(2,2,i)= rt(2,1,i) - rdt(2,3,i)= 0.0d0 - rdt(3,1,i)=-rt(3,2,i) - rdt(3,2,i)= rt(3,1,i) - rdt(3,3,i)= 0.0d0 - enddo -! -! derivatives in phi -! - do i=2,nres-2 - drt(1,1,i)= 0.0d0 - drt(1,2,i)= 0.0d0 - drt(1,3,i)= 0.0d0 - drt(2,1,i)= rt(3,1,i) - drt(2,2,i)= rt(3,2,i) - drt(2,3,i)= rt(3,3,i) - drt(3,1,i)=-rt(2,1,i) - drt(3,2,i)=-rt(2,2,i) - drt(3,3,i)=-rt(2,3,i) - enddo -! -! generate the matrix products of type r(i)t(i)...r(j)t(j) -! - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -! -! Calculate derivatives. -! - ind1=0 - do i=1,nres-2 - ind1=ind1+1 -! -! Derivatives of DC(i+1) in theta(i+2) -! - do j=1,3 - do k=1,2 - dpjk=0.0D0 - do l=1,3 - dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) - enddo - dp(j,k)=dpjk - prordt(j,k,i)=dp(j,k) - enddo - dp(j,3)=0.0D0 - dcdv(j,ind1)=vbld(i+1)*dp(j,1) - enddo -! -! Derivatives of SC(i+1) in theta(i+2) -! - xx1(1)=-0.5D0*xloc(2,i+1) - xx1(2)= 0.5D0*xloc(1,i+1) - do j=1,3 - xj=0.0D0 - do k=1,2 - xj=xj+r(j,k,i)*xx1(k) - enddo - xx(j)=xj - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j,ind1)=rj - enddo -! -! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently -! than the other off-diagonal derivatives. -! - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j,ind1+1)=dxoiij - enddo -!d print *,ind1+1,(dxdv(j,ind1+1),j=1,3) -! -! Derivatives of DC(i+1) in phi(i+2) -! - do j=1,3 - do k=1,3 - dpjk=0.0 - do l=2,3 - dpjk=dpjk+prod(j,l,i)*drt(l,k,i) - enddo - dp(j,k)=dpjk - prodrt(j,k,i)=dp(j,k) - enddo - dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) - enddo -! -! Derivatives of SC(i+1) in phi(i+2) -! - xx(1)= 0.0D0 - xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) - xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) - do j=1,3 - rj=0.0D0 - do k=2,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j+3,ind1)=-rj - enddo -! -! Derivatives of SC(i+1) in phi(i+3). -! - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j+3,ind1+1)=dxoiij - enddo -! -! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru -! theta(nres) and phi(i+3) thru phi(nres). -! - do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -!d print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo -!d print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -!d print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -!d print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) -! Derivatives of virtual-bond vectors in theta - do k=1,3 - dcdv(k,ind1)=vbld(i+1)*temp(k,1) - enddo -!d print '(3f8.3)',(dcdv(k,ind1),k=1,3) -! Derivatives of SC vectors in theta - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k,ind1+1)=dxoijk - enddo -! -!--- Calculate the derivatives in phi -! - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,3 - tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo - do k=1,3 - dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) - enddo - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k+3,ind1+1)=dxoijk - enddo - enddo - enddo -! -! Derivatives in alpha and omega: -! - do i=2,nres-1 -! dsci=dsc(itype(i)) - dsci=vbld(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if(alphi.ne.alphi) alphi=100.0 - if(omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif -!d print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 -!d print *,((temp(l,k),l=1,3),k=1,2) - do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) - enddo - dxds(jjj+k,i)=dj - enddo - jjj=jjj+3 - enddo - enddo - return - end subroutine cartder -!----------------------------------------------------------------------------- -! checkder_p.F -!----------------------------------------------------------------------------- - subroutine check_cartgrad -! Check the gradient of Cartesian coordinates in internal coordinates. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.DERIV' - real(kind=8),dimension(6,nres) :: temp - real(kind=8),dimension(3) :: xx,gg - integer :: i,k,j,ii - real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii -! indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -! -! Check the gradient of the virtual-bond and SC vectors in the internal -! coordinates. -! - aincr=1.0d-7 - aincr2=5.0d-8 - call cartder - write (iout,'(a)') '**************** dx/dalpha' - write (iout,'(a)') - do i=2,nres-1 - alphi=alph(i) - alph(i)=alph(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') & - i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - alph(i)=alphi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/domega' - write (iout,'(a)') - do i=2,nres-1 - omegi=omeg(i) - omeg(i)=omeg(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k+3,i))/ & - (aincr*dabs(dxds(k+3,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') & - i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - omeg(i)=omegi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/dtheta' - write (iout,'(a)') - do i=3,nres - theti=theta(i) - theta(i)=theta(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -! print *,'i=',i-2,' j=',j-1,' ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k,ii))/ & - (aincr*dabs(dxdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & - i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - write (iout,'(a)') - theta(i)=theti - call chainbuild - enddo - write (iout,'(a)') '***************** dx/dphi' - write (iout,'(a)') - do i=4,nres - phi(i)=phi(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -! print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ & - (aincr*dabs(dxdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & - i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - phi(i)=phi(i)-aincr - call chainbuild - enddo - write (iout,'(a)') '****************** ddc/dtheta' - do i=1,nres-2 - thet=theta(i+2) - theta(i+2)=thet+aincr - do j=i,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+1,nres-1 - ii = indmat(i,j) -! print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k,ii))/ & - (aincr*dabs(dcdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & - i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - theta(i+2)=thet - enddo - write (iout,'(a)') '******************* ddc/dphi' - do i=1,nres-3 - phii=phi(i+3) - phi(i+3)=phii+aincr - do j=1,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+2,nres-1 - ii = indmat(i+1,j) -! print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ & - (aincr*dabs(dcdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & - i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - phi(i+3)=phii - enddo - return - end subroutine check_cartgrad -!----------------------------------------------------------------------------- - subroutine check_ecart -! Check the gradient of the energy in Cartesian coordinates. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.CONTACTS' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall - real(kind=8),dimension(6) :: ggg - real(kind=8),dimension(3) :: cc,xx,ddc,ddx - real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(6,nres) :: grad_s - real(kind=8),dimension(0:n_ene) :: energia,energia1 - integer :: uiparm(1) - real(kind=8) :: urparm(1) -!EL external fdum - integer :: nf,i,j,k - real(kind=8) :: aincr,etot,etot1 - icg=1 - nf=0 - nfl=0 - call zerograd - aincr=1.0D-7 - print '(a)','CG processor',me,' calling CHECK_CART.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - call etotal(energia) - etot=energia(0) -!el call enerprint(energia) - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gradc(j,i,icg) - grad_s(j+3,i)=gradx(j,i,icg) - enddo - enddo - call flush(iout) - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=1,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - enddo - do j=1,3 - dc(j,i)=dc(j,i)+aincr - do k=i+1,nres - c(j,k)=c(j,k)+aincr - c(j,k+nres)=c(j,k+nres)+aincr - enddo - call etotal(energia1) - etot1=energia1(0) - ggg(j)=(etot1-etot)/aincr - dc(j,i)=ddc(j) - do k=i+1,nres - c(j,k)=c(j,k)-aincr - c(j,k+nres)=c(j,k+nres)-aincr - enddo - enddo - do j=1,3 - c(j,i+nres)=c(j,i+nres)+aincr - dc(j,i+nres)=dc(j,i+nres)+aincr - call etotal(energia1) - etot1=energia1(0) - ggg(j+3)=(etot1-etot)/aincr - c(j,i+nres)=xx(j) - dc(j,i+nres)=ddx(j) - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') & - i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) - enddo - return - end subroutine check_ecart -!----------------------------------------------------------------------------- - subroutine check_ecartint -! Check the gradient of the energy in Cartesian coordinates. - use io_base, only: intout -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.CONTACTS' -! include 'COMMON.MD' -! include 'COMMON.LOCAL' -! include 'COMMON.SPLITELE' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall - real(kind=8),dimension(6) :: ggg,ggg1 - real(kind=8),dimension(3) :: cc,xx,ddc,ddx - real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe - real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres) - real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres) - real(kind=8),dimension(0:n_ene) :: energia,energia1 - integer :: uiparm(1) - real(kind=8) :: urparm(1) -!EL external fdum - integer :: i,j,k,nf - real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,& - etot21,etot22 - r_cut=2.0d0 - rlambd=0.3d0 - icg=1 - nf=0 - nfl=0 - call intout -! call intcartderiv -! call checkintcartgrad - call zerograd - aincr=1.0D-4 - write(iout,*) 'Calling CHECK_ECARTINT.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - if (.not.split_ene) then - call etotal(energia) - etot=energia(0) -!el call enerprint(energia) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - else -!- split gradient check - call zerograd - call etotal_long(energia) -!el call enerprint(energia) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - write (iout,*) "longrange grad" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& - (gxcart(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - call zerograd - call etotal_short(energia) -!el call enerprint(energia) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - write (iout,*) "shortrange grad" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& - (gxcart(j,i),j=1,3) - enddo - do j=1,3 - grad_s1(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s1(j,i)=gcart(j,i) - grad_s1(j+3,i)=gxcart(j,i) - enddo - enddo - endif - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=0,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - do k=1,3 - dcnorm_safe(k)=dc_norm(k,i) - dxnorm_safe(k)=dc_norm(k,i+nres) - enddo - enddo - do j=1,3 - dc(j,i)=ddc(j)+aincr - call chainbuild_cart -#ifdef MPI -! Broadcast the order to compute internal coordinates to the slaves. -! if (nfgtasks.gt.1) -! & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -! call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1) - etot1=energia1(0) - else -!- split gradient - call etotal_long(energia1) - etot11=energia1(0) - call etotal_short(energia1) - etot12=energia1(0) -! write (iout,*) "etot11",etot11," etot12",etot12 - endif -!- end split gradient -! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i)=ddc(j)-aincr - call chainbuild_cart -! call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1) - etot2=energia1(0) - ggg(j)=(etot1-etot2)/(2*aincr) - else -!- split gradient - call etotal_long(energia1) - etot21=energia1(0) - ggg(j)=(etot11-etot21)/(2*aincr) - call etotal_short(energia1) - etot22=energia1(0) - ggg1(j)=(etot12-etot22)/(2*aincr) -!- end split gradient -! write (iout,*) "etot21",etot21," etot22",etot22 - endif -! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i)=ddc(j) - call chainbuild_cart - enddo - do j=1,3 - dc(j,i+nres)=ddx(j)+aincr - call chainbuild_cart -! write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" -! write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -! write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -! write (iout,*) "dxnormnorm",dsqrt( -! & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -! write (iout,*) "dxnormnormsafe",dsqrt( -! & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) -! write (iout,*) - if (.not.split_ene) then - call etotal(energia1) - etot1=energia1(0) - else -!- split gradient - call etotal_long(energia1) - etot11=energia1(0) - call etotal_short(energia1) - etot12=energia1(0) - endif -!- end split gradient -! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i+nres)=ddx(j)-aincr - call chainbuild_cart -! write (iout,*) "i",i," j",j," dxnorm- and dxnorm" -! write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -! write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -! write (iout,*) -! write (iout,*) "dxnormnorm",dsqrt( -! & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -! write (iout,*) "dxnormnormsafe",dsqrt( -! & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) - if (.not.split_ene) then - call etotal(energia1) - etot2=energia1(0) - ggg(j+3)=(etot1-etot2)/(2*aincr) - else -!- split gradient - call etotal_long(energia1) - etot21=energia1(0) - ggg(j+3)=(etot11-etot21)/(2*aincr) - call etotal_short(energia1) - etot22=energia1(0) - ggg1(j+3)=(etot12-etot22)/(2*aincr) -!- end split gradient - endif -! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i+nres)=ddx(j) - call chainbuild_cart - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & - i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) - if (split_ene) then - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & - i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),& - k=1,6) - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & - i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),& - ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) - endif - enddo - return - end subroutine check_ecartint -!----------------------------------------------------------------------------- - subroutine check_eint -! Check the gradient of energy in internal coordinates. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall - real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres) - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2 - character(len=6) :: key -!EL external fdum - integer :: i,ii,nf - real(kind=8) :: xi,aincr,etot,etot1,etot2 - call zerograd - aincr=1.0D-7 - print '(a)','Calling CHECK_INT.' - nf=0 - nfl=0 - icg=1 - call geom_to_var(nvar,x) - call var_to_geom(nvar,x) - call chainbuild - icall=1 - print *,'ICG=',ICG - call etotal(energia) - etot = energia(0) -!el call enerprint(energia) - print *,'ICG=',ICG -#ifdef MPL - if (MyID.ne.BossID) then - call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) - nf=x(nvar+1) - nfl=x(nvar+2) - icg=x(nvar+3) - endif -#endif - nf=1 - nfl=3 -!d write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) - call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) -!d write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp - icall=1 - do i=1,nvar - xi=x(i) - x(i)=xi-0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia1) - etot1=energia1(0) - x(i)=xi+0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia2) - etot2=energia2(0) - gg(i)=(etot2-etot1)/aincr - write (iout,*) i,etot1,etot2 - x(i)=xi - enddo - write (iout,'(/2a)')' Variable Numerical Analytical',& - ' RelDiff*100% ' - do i=1,nvar - if (i.le.nphi) then - ii=i - key = ' phi' - else if (i.le.nphi+ntheta) then - ii=i-nphi - key=' theta' - else if (i.le.nphi+ntheta+nside) then - ii=i-(nphi+ntheta) - key=' alpha' - else - ii=i-(nphi+ntheta+nside) - key=' omega' - endif - write (iout,'(i3,a,i3,3(1pd16.6))') & - i,key,ii,gg(i),gana(i),& - 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) - enddo - return - end subroutine check_eint -!----------------------------------------------------------------------------- -! econstr_local.F -!----------------------------------------------------------------------------- - subroutine Econstr_back -! MD with umbrella_sampling using Wolyne's distance measure as a constraint -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' - use MD_data -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - integer :: i,j,ii,k - real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz - - if(.not.allocated(utheta)) allocate(utheta(nfrag_back)) - if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back)) - if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back)) - - Uconst_back=0.0d0 - do i=1,nres - dutheta(i)=0.0d0 - dugamma(i)=0.0d0 - do j=1,3 - duscdiff(j,i)=0.0d0 - duscdiffx(j,i)=0.0d0 - enddo - enddo - do i=1,nfrag_back - ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) -! -! Deviations from theta angles -! - utheta_i=0.0d0 - do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) - dtheta_i=theta(j)-thetaref(j) - utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i - dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) - enddo - utheta(i)=utheta_i/(ii-1) -! -! Deviations from gamma angles -! - ugamma_i=0.0d0 - do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) - dgamma_i=pinorm(phi(j)-phiref(j)) -! write (iout,*) j,phi(j),phi(j)-phiref(j) - ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i - dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) -! write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) - enddo - ugamma(i)=ugamma_i/(ii-2) -! -! Deviations from local SC geometry -! - uscdiff(i)=0.0d0 - do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 - dxx=xxtab(j)-xxref(j) - dyy=yytab(j)-yyref(j) - dzz=zztab(j)-zzref(j) - uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz - do k=1,3 - duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* & - (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ & - (ii-1) - duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* & - (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ & - (ii-1) - duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* & - (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) & - /(ii-1) - enddo -! write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), -! & xxref(j),yyref(j),zzref(j) - enddo - uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) -! write (iout,*) i," uscdiff",uscdiff(i) -! -! Put together deviations from local geometry -! - Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ & - wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) -! write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), -! & " uconst_back",uconst_back - utheta(i)=dsqrt(utheta(i)) - ugamma(i)=dsqrt(ugamma(i)) - uscdiff(i)=dsqrt(uscdiff(i)) - enddo - return - end subroutine Econstr_back -!----------------------------------------------------------------------------- -! energy_p_new-sep_barrier.F -!----------------------------------------------------------------------------- - real(kind=8) function sscale(r) -! include "COMMON.SPLITELE" - real(kind=8) :: r,gamm - if(r.lt.r_cut-rlamb) then - sscale=1.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) - else - sscale=0d0 - endif - return - end function sscale -!----------------------------------------------------------------------------- - subroutine elj_long(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the LJ potential of interaction. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.TORSION' -! include 'COMMON.SBRIDGE' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTACTS' - real(kind=8),parameter :: accur=1.0d-10 - real(kind=8),dimension(3) :: gg -!el local variables - integer :: i,iint,j,k,itypi,itypi1,itypj - real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij - real(kind=8) :: e1,e2,evdwij,evdw -! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) -!d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -!d & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij -! -! Calculate the components of the gradient in DC and X -! - fac=-rrij*(e1+evdwij)*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -!****************************************************************************** -! -! N O T E !!! -! -! To save time, the factor of EXPON has been extracted from ALL components -! of GVDWC and GRADX. Remember to multiply them by this factor before further -! use! -! -!****************************************************************************** - return - end subroutine elj_long -!----------------------------------------------------------------------------- - subroutine elj_short(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the LJ potential of interaction. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.TORSION' -! include 'COMMON.SBRIDGE' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTACTS' - real(kind=8),parameter :: accur=1.0d-10 - real(kind=8),dimension(3) :: gg -!el local variables - integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti - real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij - real(kind=8) :: e1,e2,evdwij,evdw -! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -! Change 12/1/95 - num_conti=0 -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) -!d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -!d & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -! Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+sss*evdwij -! -! Calculate the components of the gradient in DC and X -! - fac=-rrij*(e1+evdwij)*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -!****************************************************************************** -! -! N O T E !!! -! -! To save time, the factor of EXPON has been extracted from ALL components -! of GVDWC and GRADX. Remember to multiply them by this factor before further -! use! -! -!****************************************************************************** - return - end subroutine elj_short -!----------------------------------------------------------------------------- - subroutine eljk_long(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the LJK potential of interaction. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - real(kind=8),dimension(3) :: gg - logical :: scheck -!el local variables - integer :: i,iint,j,k,itypi,itypi1,itypj - real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,& - fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij -! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -!d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -!d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -!d write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -!d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -!d & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -!d & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -!d & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+(1.0d0-sss)*evdwij -! -! Calculate the components of the gradient in DC and X -! - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end subroutine eljk_long -!----------------------------------------------------------------------------- - subroutine eljk_short(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the LJK potential of interaction. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' - real(kind=8),dimension(3) :: gg - logical :: scheck -!el local variables - integer :: i,iint,j,k,itypi,itypi1,itypj - real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,& - fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij -! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -!d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -!d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -!d write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -!d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -!d & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -!d & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -!d & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+sss*evdwij -! -! Calculate the components of the gradient in DC and X -! - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end subroutine eljk_short -!----------------------------------------------------------------------------- - subroutine ebp_long(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Berne-Pechukas potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall -! double precision rrsave(maxdim) - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac - real(kind=8) :: sss,e1,e2,evdw,sigm,epsi - evdw=0.0D0 -! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -! if (icall.eq.0) then -! lprn=.true. -! else - lprn=.false. -! endif -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) -!el ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -! Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -! Calculate whole angle-dependent part of epsilon and contributions -! to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -!d write (iout,'(2(a3,i3,2x),15(0pf7.3))') -!d & restyp(itypi),i,restyp(itypj),j, -!d & epsi,sigm,chi1,chi2,chip1,chip2, -!d & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -!d & om1,om2,om12,1.0D0/dsqrt(rrij), -!d & evdwij - endif -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -! Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate the angular part of the gradient and sum add the contributions -! to the appropriate components of the Cartesian gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -! stop - return - end subroutine ebp_long -!----------------------------------------------------------------------------- - subroutine ebp_short(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Berne-Pechukas potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall -! double precision rrsave(maxdim) - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi - real(kind=8) :: sss,e1,e2,evdw - evdw=0.0D0 -! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -! if (icall.eq.0) then -! lprn=.true. -! else - lprn=.false. -! endif -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) -!el ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -! Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -! Calculate whole angle-dependent part of epsilon and contributions -! to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -!d write (iout,'(2(a3,i3,2x),15(0pf7.3))') -!d & restyp(itypi),i,restyp(itypj),j, -!d & epsi,sigm,chi1,chi2,chip1,chip2, -!d & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -!d & om1,om2,om12,1.0D0/dsqrt(rrij), -!d & evdwij - endif -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -! Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate the angular part of the gradient and sum add the contributions -! to the appropriate components of the Cartesian gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -! stop - return - end subroutine ebp_short -!----------------------------------------------------------------------------- - subroutine egb_long(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' -! include 'COMMON.CONTROL' - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift - real(kind=8) :: sss,e1,e2,evdw - evdw=0.0D0 -!cccc energy_dec=.false. -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.false. -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -! write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) -!el ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -! & 1.0d0/vbld(j+nres) -! write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -! Calculate angle-dependent terms of energy and contributions to their -! derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -! for diagnostics; uncomment -! rij_shift=1.2*sig0ij -! I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') -!d & restyp(itypi),i,restyp(itypj),j, -!d & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -!--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -! & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') & - restyp(itypi),i,restyp(itypj),j,& - epsi,sigm,chi1,chi2,chip1,chip2,& - eps1,eps2rt**2,eps3rt**2,sig,sig0ij,& - om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& - evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'evdw',i,j,evdwij -! if (energy_dec) write (iout,*) & -! 'evdw',i,j,evdwij,"egb_long" - -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -! fac=0.0d0 -! Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -! write (iout,*) "Number of loop steps in EGB:",ind -!ccc energy_dec=.false. - return - end subroutine egb_long -!----------------------------------------------------------------------------- - subroutine egb_short(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' -! include 'COMMON.CONTROL' - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig - real(kind=8) :: sss,e1,e2,evdw,rij_shift - evdw=0.0D0 -!cccc energy_dec=.false. -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.false. -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -! write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) -!el ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -! & 1.0d0/vbld(j+nres) -! write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -! Calculate angle-dependent terms of energy and contributions to their -! derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -! for diagnostics; uncomment -! rij_shift=1.2*sig0ij -! I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') -!d & restyp(itypi),i,restyp(itypj),j, -!d & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -!--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -! & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') & - restyp(itypi),i,restyp(itypj),j,& - epsi,sigm,chi1,chi2,chip1,chip2,& - eps1,eps2rt**2,eps3rt**2,sig,sig0ij,& - om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& - evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'evdw',i,j,evdwij -! if (energy_dec) write (iout,*) & -! 'evdw',i,j,evdwij,"egb_short" - -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -! fac=0.0d0 -! Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate angular part of the gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -! write (iout,*) "Number of loop steps in EGB:",ind -!ccc energy_dec=.false. - return - end subroutine egb_short -!----------------------------------------------------------------------------- - subroutine egbv_long(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne-Vorobjev potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij - real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift - evdw=0.0D0 -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.true. -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) -!el ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -! Calculate angle-dependent terms of energy and contributions to their -! derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -! I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -!--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') & - restyp(itypi),i,restyp(itypj),j,& - epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),& - chi1,chi2,chip1,chip2,& - eps1,eps2rt**2,eps3rt**2,& - om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& - evdwij+e_augm - endif -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -! Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end subroutine egbv_long -!----------------------------------------------------------------------------- - subroutine egbv_short(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne-Vorobjev potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift - real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm - evdw=0.0D0 -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.true. -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) -!el ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -! Calculate angle-dependent terms of energy and contributions to their -! derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -! I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -!--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') & - restyp(itypi),i,restyp(itypj),j,& - epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),& - chi1,chi2,chip1,chip2,& - eps1,eps2rt**2,eps3rt**2,& - om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& - evdwij+e_augm - endif -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -! Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate angular part of the gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end subroutine egbv_short -!----------------------------------------------------------------------------- - subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -! -! This subroutine calculates the average interaction energy and its gradient -! in the virtual-bond vectors between non-adjacent peptide groups, based on -! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -! The potential depends both on the distance of peptide-group centers and on -! the orientation of the CA-CA virtual bonds. -! -! implicit real*8 (a-h,o-z) - - use comm_locel -#ifdef MPI - include 'mpif.h' -#endif -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VECTORS' -! include 'COMMON.FFIELD' -! include 'COMMON.TIME1' - real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg - real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg - real(kind=8),dimension(2,2) :: acipa !el,a_temp -!el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 - real(kind=8),dimension(4) :: muij -!el integer :: num_conti,j1,j2 -!el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& -!el dz_normi,xmedi,ymedi,zmedi -!el common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,& -!el dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& -!el num_conti,j1,j2 -! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - real(kind=8) :: scal_el=1.0d0 -#else - real(kind=8) :: scal_el=0.5d0 -#endif -! 12/13/98 -! 13-go grudnia roku pamietnego... - real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,& - 0.0d0,1.0d0,0.0d0,& - 0.0d0,0.0d0,1.0d0/),shape(unmat)) -!el local variables - integer :: i,j,k - real(kind=8) :: fac - real(kind=8) :: dxj,dyj,dzj - real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4 - -! allocate(num_cont_hb(nres)) !(maxres) -!d write(iout,*) 'In EELEC' -!d do i=1,nloctyp -!d write(iout,*) 'Type',i -!d write(iout,*) 'B1',B1(:,i) -!d write(iout,*) 'B2',B2(:,i) -!d write(iout,*) 'CC',CC(:,:,i) -!d write(iout,*) 'DD',DD(:,:,i) -!d write(iout,*) 'EE',EE(:,:,i) -!d enddo -!d call check_vecgrad -!d stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -! write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & - .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. & - wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -! call vec_and_deriv -#ifdef TIMING - time01=MPI_Wtime() -#endif - call set_matrices -#ifdef TIMING - time_mat=time_mat+MPI_Wtime()-time01 -#endif - endif -!d do i=1,nres-1 -!d write (iout,*) 'i=',i -!d do k=1,3 -!d write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -!d enddo -!d do k=1,3 -!d write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -!d & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -!d enddo -!d enddo - t_eelecij=0.0d0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 -!el ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -!d print '(a)','Enter EELEC' -!d write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e -! if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres) -! if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres) - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo -! -! -! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms -! -! Loop over i,i+2 and i,i+3 pairs of the peptide groups -! - do i=iturn3_start,iturn3_end - if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 & - .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 - call eelecij_scale(i,i+2,ees,evdw1,eel_loc) - if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) - num_cont_hb(i)=num_conti - enddo - do i=iturn4_start,iturn4_end - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 & - .or. itype(i+3).eq.ntyp1 & - .or. itype(i+4).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=num_cont_hb(i) - call eelecij_scale(i,i+3,ees,evdw1,eel_loc) - if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & - call eturn4(i,eello_turn4) - num_cont_hb(i)=num_conti - enddo ! i -! -! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 -! - do i=iatel_s,iatel_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi -! write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - num_conti=num_cont_hb(i) - do j=ielstart(i),ielend(i) - if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle - call eelecij_scale(i,j,ees,evdw1,eel_loc) - enddo ! j - num_cont_hb(i)=num_conti - enddo ! i -! write (iout,*) "Number of loop steps in EELEC:",ind -!d do i=1,nres -!d write (iout,'(i3,3f10.5,5x,3f10.5)') -!d & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -!d enddo -! 12/7/99 Adam eello_turn3 will be considered as a separate energy term -!cc eel_loc=eel_loc+eello_turn3 -!d print *,"Processor",fg_rank," t_eelecij",t_eelecij - return - end subroutine eelec_scale -!----------------------------------------------------------------------------- - subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) -! implicit real*8 (a-h,o-z) - - use comm_locel -! include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VECTORS' -! include 'COMMON.FFIELD' -! include 'COMMON.TIME1' - real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg - real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg - real(kind=8),dimension(2,2) :: acipa !el,a_temp -!el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 - real(kind=8),dimension(4) :: muij -!el integer :: num_conti,j1,j2 -!el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& -!el dz_normi,xmedi,ymedi,zmedi -!el common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,& -!el dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& -!el num_conti,j1,j2 -! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - real(kind=8) :: scal_el=1.0d0 -#else - real(kind=8) :: scal_el=0.5d0 -#endif -! 12/13/98 -! 13-go grudnia roku pamietnego... - real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,& - 0.0d0,1.0d0,0.0d0,& - 0.0d0,0.0d0,1.0d0/),shape(unmat)) -!el local variables - integer :: i,j,k,l,iteli,itelj,kkk,kkll,m - real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj - real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac - real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij - real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont - real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp - real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,& - dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,& - ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,& - wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,& - ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,& - ecosam,ecosbm,ecosgm,ghalf,time00 -! integer :: maxconts -! maxconts = nres/4 -! allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) -! allocate(facont_hb(maxconts,nres)) !(maxconts,maxres) -! allocate(ees0p(maxconts,nres)) !(maxconts,maxres) -! allocate(ees0m(maxconts,nres)) !(maxconts,maxres) -! allocate(d_cont(maxconts,nres)) !(maxconts,maxres) -! allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres) - -! allocate(a_chuj(2,2,maxconts,nres)) !(2,2,maxconts,maxres) -! allocate(a_chuj_der(2,2,3,5,maxconts,nres)) !(2,2,3,5,maxconts,maxres) - -#ifdef MPI - time00=MPI_Wtime() -#endif -!d write (iout,*) "eelecij",i,j -!el ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij -! For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) - - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -! 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-sss) -!d write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') -!d & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, -!d & 1.0D0/dsqrt(rrmij),evdwij,eesij, -!d & xmedi,ymedi,zmedi,xj,yj,zj - - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - -! -! Calculate contributions to the Cartesian gradient. -! -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -! -! Radial derivatives. First process both termini of the fragment (i,j) -! - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj -! do k=1,3 -! ghalf=0.5D0*ggg(k) -! gelc(k,i)=gelc(k,i)+ghalf -! gelc(k,j)=gelc(k,j)+ghalf -! enddo -! 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo -! -! Loop over residues i+1 thru j-1. -! -!grad do k=i+1,j-1 -!grad do l=1,3 -!grad gelc(l,k)=gelc(l,k)+ggg(l) -!grad enddo -!grad enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj -! do k=1,3 -! ghalf=0.5D0*ggg(k) -! gvdwpp(k,i)=gvdwpp(k,i)+ghalf -! gvdwpp(k,j)=gvdwpp(k,j)+ghalf -! enddo -! 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -! -! Loop over residues i+1 thru j-1. -! -!grad do k=i+1,j-1 -!grad do l=1,3 -!grad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) -!grad enddo -!grad enddo -#else - facvdw=ev1+evdwij*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -! -! Radial derivatives. First process both termini of the fragment (i,j) -! - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj -! do k=1,3 -! ghalf=0.5D0*ggg(k) -! gelc(k,i)=gelc(k,i)+ghalf -! gelc(k,j)=gelc(k,j)+ghalf -! enddo -! 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc(k,j)+ggg(k) - gelc_long(k,i)=gelc(k,i)-ggg(k) - enddo -! -! Loop over residues i+1 thru j-1. -! -!grad do k=i+1,j-1 -!grad do l=1,3 -!grad gelc(l,k)=gelc(l,k)+ggg(l) -!grad enddo -!grad enddo -! 9/28/08 AL Gradient compotents will be summed only at the end - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -#endif -! -! Angular part -! - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -!d print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -!d & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo -! do k=1,3 -! ghalf=0.5D0*ggg(k) -! gelc(k,i)=gelc(k,i)+ghalf -! & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) -! & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) -! gelc(k,j)=gelc(k,j)+ghalf -! & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) -! & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) -! enddo -!grad do k=i+1,j-1 -!grad do l=1,3 -!grad gelc(l,k)=gelc(l,k)+ggg(l) -!grad enddo -!grad enddo - do k=1,3 - gelc(k,i)=gelc(k,i) & - +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) & - + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j) & - +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) & - + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & - .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 & - .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -! -! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction -! energy of a peptide unit is assumed in the form of a second-order -! Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. -! Macromolecules, 1974, 7, 797-806 for definition). This correlation terms -! are computed for EVERY pair of non-contiguous peptide groups. -! - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -!d write (iout,*) 'EELEC: i',i,' j',j -!d write (iout,*) 'j',j,' j1',j1,' j2',j2 -!d write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz - fac=dsqrt(-ael6i)*r3ij - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -!d write (iout,'(4i5,4f10.5)') -!d & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 -!d write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij -!d write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), -!d & uy(:,j),uz(:,j) -!d write (iout,'(4f10.5)') -!d & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), -!d & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) -!d write (iout,'(4f10.5)') ury,urz,vry,vrz -!d write (iout,'(9f10.5/)') -!d & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij -! Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) - do k=1,3 - uryg(k,1)=scalar(erder(1,k),uy(1,i)) - uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) - uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) - urzg(k,1)=scalar(erder(1,k),uz(1,i)) - urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) - urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) - vryg(k,1)=scalar(erder(1,k),uy(1,j)) - vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) - vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) - vrzg(k,1)=scalar(erder(1,k),uz(1,j)) - vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) - vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) - enddo -! Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj -! Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 -! Derivatives in DC(i) -!grad ghalf1=0.5d0*agg(k,1) -!grad ghalf2=0.5d0*agg(k,2) -!grad ghalf3=0.5d0*agg(k,3) -!grad ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) & - -3.0d0*uryg(k,2)*vry)!+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) & - -3.0d0*uryg(k,2)*vrz)!+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) & - -3.0d0*urzg(k,2)*vry)!+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) & - -3.0d0*urzg(k,2)*vrz)!+ghalf4 -! Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) & - -3.0d0*uryg(k,3)*vry)!+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) & - -3.0d0*uryg(k,3)*vrz)!+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) & - -3.0d0*urzg(k,3)*vry)!+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) & - -3.0d0*urzg(k,3)*vrz)!+agg(k,4) -! Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) & - -3.0d0*vryg(k,2)*ury)!+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) & - -3.0d0*vrzg(k,2)*ury)!+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) & - -3.0d0*vryg(k,2)*urz)!+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) & - -3.0d0*vrzg(k,2)*urz)!+ghalf4 -! Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) & - -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) & - -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) & - -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) & - -3.0d0*vrzg(k,3)*urz) -!grad if (j.eq.nres-1 .and. i.lt.j-2) then -!grad do l=1,4 -!grad aggj1(k,l)=aggj1(k,l)+agg(k,l) -!grad enddo -!grad endif - enddo - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 - a22=-a22 - a23=-a23 - do l=1,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR - IF (wel_loc.gt.0.0d0) THEN -! Contribution to the local-electrostatic energy coming from the i-j pair - eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) & - +a33*muij(4) -! write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'eelloc',i,j,eel_loc_ij -! write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d - - eel_loc=eel_loc+eel_loc_ij -! Partial derivatives in virtual-bond dihedral angles gamma - if (i.gt.1) & - gel_loc_loc(i-1)=gel_loc_loc(i-1)+ & - a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) & - +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ & - a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) & - +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) -! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) - do l=1,3 - ggg(l)=agg(l,1)*muij(1)+ & - agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) - gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) - gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) -!grad ghalf=0.5d0*ggg(l) -!grad gel_loc(l,i)=gel_loc(l,i)+ghalf -!grad gel_loc(l,j)=gel_loc(l,j)+ghalf - enddo -!grad do k=i+1,j2 -!grad do l=1,3 -!grad gel_loc(l,k)=gel_loc(l,k)+ggg(l) -!grad enddo -!grad enddo -! Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ & - aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ & - aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ & - aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ & - aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - ENDIF -! Change 12/26/95 to calculate four-body contributions to H-bonding energy -! if (j.gt.i+1 .and. num_conti.le.maxconts) then - if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & - .and. num_conti.le.maxconts) then -! write (iout,*) i,j," entered corr" -! -! Calculate the contact function. The ith column of the array JCONT will -! contain the numbers of atoms that make contacts with the atom I (of numbers -! greater than I). The arrays FACONT and GACONT will contain the values of -! the contact function and its derivative. -! r0ij=1.02D0*rpp(iteli,itelj) -! r0ij=1.11D0*rpp(iteli,itelj) - r0ij=2.20D0*rpp(iteli,itelj) -! r0ij=1.55D0*rpp(iteli,itelj) - call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) -!elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts - if (fcont.gt.0.0D0) then - num_conti=num_conti+1 - if (num_conti.gt.maxconts) then -!elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts - write (iout,*) 'WARNING - max. # of contacts exceeded;',& - ' will skip next contacts for this conf.',num_conti - else - jcont_hb(num_conti,i)=j -!d write (iout,*) "i",i," j",j," num_conti",num_conti, -!d & " jcont_hb",jcont_hb(num_conti,i) - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. & - wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el -! terms. - d_cont(num_conti,i)=rij -!d write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij -! --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 -! --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo - kkll=0 - do k=1,2 - do l=1,2 - kkll=kkll+1 - do m=1,3 - a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) - a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) - a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) - a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) - a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) - enddo - enddo - enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN -! Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -! fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij -! ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 - if (ees0tmp.gt.0) then - ees0pij=dsqrt(ees0tmp) - else - ees0pij=0 - endif -! ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) - ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 - if (ees0tmp.gt.0) then - ees0mij=dsqrt(ees0tmp) - else - ees0mij=0 - endif -! ees0mij=0.0D0 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -! Diagnostics. Comment out or remove after debugging! -! ees0p(num_conti,i)=0.5D0*fac3*ees0pij -! ees0m(num_conti,i)=0.5D0*fac3*ees0mij -! ees0m(num_conti,i)=0.0D0 -! End diagnostics. -! write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, -! & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont -! Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -! ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 -! Diagnostics -! ecosap=ecosa1 -! ecosbp=ecosb1 -! ecosgp=ecosg1 -! ecosam=0.0D0 -! ecosbm=0.0D0 -! ecosgm=0.0D0 -! End diagnostics - facont_hb(num_conti,i)=fcont - fprimcont=fprimcont/rij -!d facont_hb(num_conti,i)=1.0D0 -! Following line is for diagnostics. -!d fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj -! Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 -! -! 10/24/08 cgrad and ! comments indicate the parts of the code removed -! following the change of gradient-summation algorithm. -! -!grad ghalfp=0.5D0*gggp(k) -!grad ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)= & !ghalfp - +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & - + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontp_hb2(k,num_conti,i)= & !ghalfp - +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & - + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)= &!ghalfm - +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & - + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)= & !ghalfm - +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & - + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then - do k=1,4 - do l=1,3 - ghalf=0.5d0*agg(l,k) - aggi(l,k)=aggi(l,k)+ghalf - aggi1(l,k)=aggi1(l,k)+agg(l,k) - aggj(l,k)=aggj(l,k)+ghalf - enddo - enddo - if (j.eq.nres-1 .and. i.lt.j-2) then - do k=1,4 - do l=1,3 - aggj1(l,k)=aggj1(l,k)+agg(l,k) - enddo - enddo - endif - endif -! t_eelecij=t_eelecij+MPI_Wtime()-time00 - return - end subroutine eelecij_scale -!----------------------------------------------------------------------------- - subroutine evdwpp_short(evdw1) -! -! Compute Evdwpp -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORSION' -! include 'COMMON.VECTORS' -! include 'COMMON.FFIELD' - real(kind=8),dimension(3) :: ggg -! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - real(kind=8) :: scal_el=1.0d0 -#else - real(kind=8) :: scal_el=0.5d0 -#endif -!el local variables - integer :: i,j,k,iteli,itelj,num_conti - real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb - real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,& - dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& - dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw - - evdw1=0.0D0 -! write (iout,*) "iatel_s_vdw",iatel_s_vdw, -! & " iatel_e_vdw",iatel_e_vdw - call flush(iout) - do i=iatel_s_vdw,iatel_e_vdw - if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -! write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), -! & ' ielend',ielend_vdw(i) - call flush(iout) - do j=ielstart_vdw(i),ielend_vdw(i) - if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle -!el ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - sss=sscale(rij/rpp(iteli,itelj)) - if (sss.gt.0.0d0) then - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - ev1=aaa*r6ij*r6ij -! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - evdwij=ev1+ev2 - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - endif - evdw1=evdw1+evdwij*sss -! -! Calculate contributions to the Cartesian gradient. -! - facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo - endif - enddo ! j - enddo ! i - return - end subroutine evdwpp_short -!----------------------------------------------------------------------------- - subroutine escp_long(evdw2,evdw2_14) -! -! This subroutine calculates the excluded-volume interaction energy between -! peptide-group centers and side chains and its gradient in virtual-bond and -! side-chain vectors. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' - real(kind=8),dimension(3) :: ggg -!el local variables - integer :: i,iint,j,k,iteli,itypj - real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2 - real(kind=8) :: evdw2,evdw2_14,evdwij - evdw2=0.0D0 - evdw2_14=0.0d0 -!d print '(a)','Enter ESCP' -!d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! Uncomment following three lines for SC-p interactions -! xj=c(1,nres+j)-xi -! yj=c(2,nres+j)-yi -! zj=c(3,nres+j)-zi -! Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.lt.1.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) - if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & - 'evdw2',i,j,sss,evdwij -! -! Calculate contributions to the gradient in the virtual-bond and SC vectors. -! - fac=-(evdwij+e1)*rrij*(1.0d0-sss) - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -! Uncomment following three lines for SC-p interactions -! do k=1,3 -! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -! enddo -! Uncomment following line for SC-p interactions -! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -!****************************************************************************** -! -! N O T E !!! -! -! To save time the factor EXPON has been extracted from ALL components -! of GVDWC and GRADX. Remember to multiply them by this factor before further -! use! -! -!****************************************************************************** - return - end subroutine escp_long -!----------------------------------------------------------------------------- - subroutine escp_short(evdw2,evdw2_14) -! -! This subroutine calculates the excluded-volume interaction energy between -! peptide-group centers and side chains and its gradient in virtual-bond and -! side-chain vectors. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' - real(kind=8),dimension(3) :: ggg -!el local variables - integer :: i,iint,j,k,iteli,itypj - real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2 - real(kind=8) :: evdw2,evdw2_14,evdwij - evdw2=0.0D0 - evdw2_14=0.0d0 -!d print '(a)','Enter ESCP' -!d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -! Uncomment following three lines for SC-p interactions -! xj=c(1,nres+j)-xi -! yj=c(2,nres+j)-yi -! zj=c(3,nres+j)-zi -! Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.gt.0.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*sss - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*sss - if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & - 'evdw2',i,j,sss,evdwij -! -! Calculate contributions to the gradient in the virtual-bond and SC vectors. -! - fac=-(evdwij+e1)*rrij*sss - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -! Uncomment following three lines for SC-p interactions -! do k=1,3 -! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -! enddo -! Uncomment following line for SC-p interactions -! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -!****************************************************************************** -! -! N O T E !!! -! -! To save time the factor EXPON has been extracted from ALL components -! of GVDWC and GRADX. Remember to multiply them by this factor before further -! use! -! -!****************************************************************************** - return - end subroutine escp_short -!----------------------------------------------------------------------------- -! energy_p_new-sep_barrier.F -!----------------------------------------------------------------------------- - subroutine sc_grad_scale(scalfac) -! implicit real*8 (a-h,o-z) - use calc_data -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.CALC' -! include 'COMMON.IOUNITS' - real(kind=8),dimension(3) :: dcosom1,dcosom2 - real(kind=8) :: scalfac -!el local variables -! integer :: i,j,k,l - - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & - -2.0D0*alf12*eps3der+sigder*sigsq_om12 -! diagnostics only -! eom1=0.0d0 -! eom2=0.0d0 -! eom12=evdwij*eps1_om12 -! end diagnostics -! write (iout,*) "eps2der",eps2der," eps3der",eps3der, -! & " sigder",sigder -! write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 -! write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac - enddo -! write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) & - +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & - +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac - gvdwx(k,j)=gvdwx(k,j)+gg(k) & - +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & - +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac -! write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) -! & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv -! write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) -! & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -! -! Calculate the components of the gradient in DC and X -! - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - return - end subroutine sc_grad_scale -!----------------------------------------------------------------------------- -! energy_split-sep.F -!----------------------------------------------------------------------------- - subroutine etotal_long(energia) -! -! Compute the long-range slow-varying contributions to the energy -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use MD_data, only: totT -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw -#endif -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.MD' - real(kind=8),dimension(0:n_ene) :: energia -!el local variables - integer :: i,n_corr,n_corr1,ierror,ierr - real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,& - evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,& - ecorr,ecorr5,ecorr6,eturn6,time00 -! write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot -!elwrite(iout,*)"in etotal long" - - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI -! if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -!elwrite(iout,*)"in etotal long" - -#ifdef MPI -! write(iout,*) "ETOTAL_LONG Processor",fg_rank, -! & " absolute rank",myrank," nfgtasks",nfgtasks - call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -! FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) -! write (iout,*) "Processor",myrank," BROADCAST iorder" -! call flush(iout) -! FG master sets up the WEIGHTS_ array which will be broadcast to the -! FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -! FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene,& - MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -! FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene,& - MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -! call chainbuild_cart -! call int_from_cart1(.false.) - endif -! write (iout,*) 'Processor',myrank, -! & ' calling etotal_short ipot=',ipot -! call flush(iout) -! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -!d print *,'nnt=',nnt,' nct=',nct -! -!elwrite(iout,*)"in etotal long" -! Compute the side-chain and electrostatic interaction energy -! - goto (101,102,103,104,105,106) ipot -! Lennard-Jones potential. - 101 call elj_long(evdw) -!d print '(a)','Exit ELJ' - goto 107 -! Lennard-Jones-Kihara potential (shifted). - 102 call eljk_long(evdw) - goto 107 -! Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_long(evdw) - goto 107 -! Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_long(evdw) - goto 107 -! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_long(evdw) - goto 107 -! Soft-sphere potential - 106 call e_softsphere(evdw) -! -! Calculate electrostatic (H-bonding) energy of the main chain. -! - 107 continue - call vec_and_deriv - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. & - wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & - .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & - .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. & - wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 & - .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & - .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0 - evdw1=0 - eel_loc=0 - eello_turn3=0 - eello_turn4=0 - endif - else -! write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,& - eello_turn4) - endif -! -! Calculate excluded-volume interaction energy between peptide groups -! and side chains. -! - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp_long(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else - call escp_soft_sphere(evdw2,evdw2_14) - endif -! -! 12/1/95 Multi-body terms -! - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 & - .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -! write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, -! &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - endif -! -! If performing constraint dynamics, call the constraint energy -! after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -! -! Sum the energies -! - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(20)=Uconst+Uconst_back - call sum_energy(energia,.true.) -! write (iout,*) "Exit ETOTAL_LONG" - call flush(iout) - return - end subroutine etotal_long -!----------------------------------------------------------------------------- - subroutine etotal_short(energia) -! -! Compute the short-range fast-varying contributions to the energy -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - integer :: ierror,ierr - real(kind=8),dimension(n_ene) :: weights_ - real(kind=8) :: time00 -#endif -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.DERIV' -! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' - real(kind=8),dimension(0:n_ene) :: energia -!el local variables - integer :: i,nres6 - real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors - real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr - nres6=6*nres - -! write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot -! call flush(iout) - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI - if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -! write(iout,*) "ETOTAL_SHORT Processor",fg_rank, -! & " absolute rank",myrank," nfgtasks",nfgtasks -! call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -! FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) -! write (iout,*) "Processor",myrank," BROADCAST iorder" -! call flush(iout) -! FG master sets up the WEIGHTS_ array which will be broadcast to the -! FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -! FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene,& - MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -! FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene,& - MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif -! write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -! write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -! write (iout,*) 'Processor',myrank, -! & ' calling etotal_short ipot=',ipot -! call flush(iout) -! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -! call int_from_cart1(.false.) -! -! Compute the side-chain and electrostatic interaction energy -! - goto (101,102,103,104,105,106) ipot -! Lennard-Jones potential. - 101 call elj_short(evdw) -!d print '(a)','Exit ELJ' - goto 107 -! Lennard-Jones-Kihara potential (shifted). - 102 call eljk_short(evdw) - goto 107 -! Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_short(evdw) - goto 107 -! Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_short(evdw) - goto 107 -! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_short(evdw) - goto 107 -! Soft-sphere potential - already dealt with in the long-range part - 106 evdw=0.0d0 -! 106 call e_softsphere_short(evdw) -! -! Calculate electrostatic (H-bonding) energy of the main chain. -! - 107 continue -! -! Calculate the short-range part of Evdwpp -! - call evdwpp_short(evdw1) -! -! Calculate the short-range part of ESCp -! - if (ipot.lt.6) then - call escp_short(evdw2,evdw2_14) - endif -! -! Calculate the bond-stretching energy -! - call ebond(estr) -! -! Calculate the disulfide-bridge and other energy and the contributions -! from other distance constraints. - call edis(ehpb) -! -! Calculate the virtual-bond-angle energy. -! - call ebend(ebe) -! -! Calculate the SC local energy. -! - call vec_and_deriv - call esc(escloc) -! -! Calculate the virtual-bond torsional energy. -! - call etor(etors,edihcnstr) -! -! 6/23/01 Calculate double-torsional energy -! - call etor_d(etors_d) -! -! 21/5/07 Calculate local sicdechain correlation energy -! - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -! -! Put energy components into an array -! - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(16)=evdw1 -#else - energia(3)=evdw1 -#endif - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(17)=estr - energia(19)=edihcnstr - energia(21)=esccor -! write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" - call flush(iout) - call sum_energy(energia,.true.) -! write (iout,*) "Exit ETOTAL_SHORT" - call flush(iout) - return - end subroutine etotal_short -!----------------------------------------------------------------------------- -! gnmr1.f -!----------------------------------------------------------------------------- - real(kind=8) function gnmr1(y,ymin,ymax) -! implicit none - real(kind=8) :: y,ymin,ymax - real(kind=8) :: wykl=4.0d0 - if (y.lt.ymin) then - gnmr1=(ymin-y)**wykl/wykl - else if (y.gt.ymax) then - gnmr1=(y-ymax)**wykl/wykl - else - gnmr1=0.0d0 - endif - return - end function gnmr1 -!----------------------------------------------------------------------------- - real(kind=8) function gnmr1prim(y,ymin,ymax) -! implicit none - real(kind=8) :: y,ymin,ymax - real(kind=8) :: wykl=4.0d0 - if (y.lt.ymin) then - gnmr1prim=-(ymin-y)**(wykl-1) - else if (y.gt.ymax) then - gnmr1prim=(y-ymax)**(wykl-1) - else - gnmr1prim=0.0d0 - endif - return - end function gnmr1prim -!----------------------------------------------------------------------------- - real(kind=8) function harmonic(y,ymax) -! implicit none - real(kind=8) :: y,ymax - real(kind=8) :: wykl=2.0d0 - harmonic=(y-ymax)**wykl - return - end function harmonic -!----------------------------------------------------------------------------- - real(kind=8) function harmonicprim(y,ymax) - real(kind=8) :: y,ymin,ymax - real(kind=8) :: wykl=2.0d0 - harmonicprim=(y-ymax)*wykl - return - end function harmonicprim -!----------------------------------------------------------------------------- -! gradient_p.F -!----------------------------------------------------------------------------- - subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) - - use io_base, only:intout,briefout -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' - real(kind=8),external :: ufparm - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) - real(kind=8) :: f,gthetai,gphii,galphai,gomegai - integer :: n,nf,ind,ind1,i,k,j -! -! This subroutine calculates total internal coordinate gradient. -! Depending on the number of function evaluations, either whole energy -! is evaluated beforehand, Cartesian coordinates and their derivatives in -! internal coordinates are reevaluated or only the cartesian-in-internal -! coordinate derivatives are evaluated. The subroutine was designed to work -! with SUMSL. -! -! - icg=mod(nf,2)+1 - -!d print *,'grad',nf,icg - if (nf-nfl+1) 20,30,40 - 20 call func(n,x,nf,f,uiparm,urparm,ufparm) -! write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom(n,x) - call chainbuild -! write (iout,*) 'grad 30' -! -! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -! - 40 call cartder -! write (iout,*) 'grad 40' -! print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon -! -! Convert the Cartesian gradient into internal-coordinate gradient. -! - ind=0 - ind1=0 - do i=1,nres-2 - gthetai=0.0D0 - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 -! ind=indmat(i,j) -! print *,'GRAD: i=',i,' jc=',j,' ind=',ind - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - enddo - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - enddo - enddo - do j=i+1,nres-1 - ind1=ind1+1 -! ind1=indmat(i,j) -! print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 - do k=1,3 - gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) - gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) - enddo - enddo - if (i.gt.1) g(i-1)=gphii - if (n.gt.nphi) g(nphi+i)=gthetai - enddo - if (n.le.nphi+ntheta) goto 10 - do i=2,nres-1 - if (itype(i).ne.10) then - galphai=0.0D0 - gomegai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ialph(i,1))=galphai - g(ialph(i,1)+nside)=gomegai - endif - enddo -! -! Add the components corresponding to local energy terms. -! - 10 continue - do i=1,nvar -!d write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) - g(i)=g(i)+gloc(i,icg) - enddo -! Uncomment following three lines for diagnostics. -!d call intout -!elwrite(iout,*) "in gradient after calling intout" -!d call briefout(0,0.0d0) -!d write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) - return - end subroutine gradient -!----------------------------------------------------------------------------- - subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F - - use comm_chu -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' - integer :: n,nf -!el integer :: jjj -!el common /chuju/ jjj - real(kind=8) :: energia(0:n_ene) - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8) :: f - real(kind=8),external :: ufparm - real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) -! if (jjj.gt.0) then -! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -! endif - nfl=nf - icg=mod(nf,2)+1 -!d print *,'func',nf,nfl,icg - call var_to_geom(n,x) - call zerograd - call chainbuild -!d write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia) - call sum_gradient - f=energia(0) -! if (jjj.gt.0) then -! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -! write (iout,*) 'f=',etot -! jjj=0 -! endif - return - end subroutine func -!----------------------------------------------------------------------------- - subroutine cartgrad -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use energy_data - use MD_data, only: totT -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! - integer :: i,j - -! This subrouting calculates total Cartesian coordinate gradient. -! The subroutine chainbuild_cart and energy MUST be called beforehand. -! -!el#define DEBUG -#ifdef TIMING - time00=MPI_Wtime() -#endif - icg=1 - call sum_gradient -#ifdef TIMING -#endif -!el write (iout,*) "After sum_gradient" -#ifdef DEBUG -!el write (iout,*) "After sum_gradient" - do i=1,nres-1 - write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) - write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) - enddo -#endif -! If performing constraint dynamics, add the gradients of the constraint energy - if(usampl.and.totT.gt.eq_time) then - do i=1,nct - do j=1,3 - gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) - gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) - enddo - enddo - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+dugamma(i) - enddo - do i=1,nres-2 - gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) - enddo - endif -!elwrite (iout,*) "After sum_gradient" -#ifdef TIMING - time01=MPI_Wtime() -#endif - call intcartderiv -!elwrite (iout,*) "After sum_gradient" -#ifdef TIMING - time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 -#endif -! call checkintcartgrad -! write(iout,*) 'calling int_to_cart' -#ifdef DEBUG - write (iout,*) "gcart, gxcart, gloc before int_to_cart" -#endif - do i=1,nct - do j=1,3 - gcart(j,i)=gradc(j,i,icg) - gxcart(j,i)=gradx(j,i,icg) - enddo -#ifdef DEBUG - write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),& - (gxcart(j,i),j=1,3),gloc(i,icg) -#endif - enddo -#ifdef TIMING - time01=MPI_Wtime() -#endif - call int_to_cart -#ifdef TIMING - time_inttocart=time_inttocart+MPI_Wtime()-time01 -#endif -#ifdef DEBUG - write (iout,*) "gcart and gxcart after int_to_cart" - do i=0,nres-1 - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& - (gxcart(j,i),j=1,3) - enddo -#endif -#ifdef TIMING - time_cartgrad=time_cartgrad+MPI_Wtime()-time00 -#endif -!el#undef DEBUG - return - end subroutine cartgrad -!----------------------------------------------------------------------------- - subroutine zerograd -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.DERIV' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.MD' -! include 'COMMON.SCCOR' -! -!el local variables - integer :: i,j,intertyp -! Initialize Cartesian-coordinate gradient -! -! if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2) -! if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2) - -! allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres)) -! allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres)) -! allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres)) -! allocate(gradcorr_long(3,nres)) -! allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres)) -! allocate(gcorr6_turn_long(3,nres)) -! allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres) - -! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres) - -! allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres)) -! allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres)) - -! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) -! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) - -! allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres) -! allocate(gscloc(3,nres)) !(3,maxres) -! if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres) - - - -! common /deriv_scloc/ -! allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres)) -! allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres)) -! allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres)) !(3,maxres) -! common /mpgrad/ -! allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres) - - - -! gradc(j,i,icg)=0.0d0 -! gradx(j,i,icg)=0.0d0 - -! allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres -!elwrite(iout,*) "icg",icg - do i=1,nres - do j=1,3 - gvdwx(j,i)=0.0D0 - gradx_scp(j,i)=0.0D0 - gvdwc(j,i)=0.0D0 - gvdwc_scp(j,i)=0.0D0 - gvdwc_scpp(j,i)=0.0d0 - gelc(j,i)=0.0D0 - gelc_long(j,i)=0.0D0 - gradb(j,i)=0.0d0 - gradbx(j,i)=0.0d0 - gvdwpp(j,i)=0.0d0 - gel_loc(j,i)=0.0d0 - gel_loc_long(j,i)=0.0d0 - ghpbc(j,i)=0.0D0 - ghpbx(j,i)=0.0D0 - gcorr3_turn(j,i)=0.0d0 - gcorr4_turn(j,i)=0.0d0 - gradcorr(j,i)=0.0d0 - gradcorr_long(j,i)=0.0d0 - gradcorr5_long(j,i)=0.0d0 - gradcorr6_long(j,i)=0.0d0 - gcorr6_turn_long(j,i)=0.0d0 - gradcorr5(j,i)=0.0d0 - gradcorr6(j,i)=0.0d0 - gcorr6_turn(j,i)=0.0d0 - gsccorc(j,i)=0.0d0 - gsccorx(j,i)=0.0d0 - gradc(j,i,icg)=0.0d0 - gradx(j,i,icg)=0.0d0 - gscloc(j,i)=0.0d0 - gsclocx(j,i)=0.0d0 - do intertyp=1,3 - gloc_sc(intertyp,i,icg)=0.0d0 - enddo - enddo - enddo -! -! Initialize the gradient of local energy terms. -! -! allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres) -! if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres) -! if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres) -! allocate(g_corr5_loc(nres),g_corr6_loc(nres)) !(maxvar)(maxvar=6*maxres) -! allocate(gel_loc_turn3(nres)) -! allocate(gel_loc_turn4(nres),gel_loc_turn6(nres)) !(maxvar)(maxvar=6*maxres) -! allocate(gsccor_loc(nres)) !(maxres) - - do i=1,4*nres - gloc(i,icg)=0.0D0 - enddo - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - g_corr5_loc(i)=0.0d0 - g_corr6_loc(i)=0.0d0 - gel_loc_turn3(i)=0.0d0 - gel_loc_turn4(i)=0.0d0 - gel_loc_turn6(i)=0.0d0 - gsccor_loc(i)=0.0d0 - enddo -! initialize gcart and gxcart -! allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES) - do i=0,nres - do j=1,3 - gcart(j,i)=0.0d0 - gxcart(j,i)=0.0d0 - enddo - enddo - return - end subroutine zerograd -!----------------------------------------------------------------------------- - real(kind=8) function fdum() - fdum=0.0D0 - return - end function fdum -!----------------------------------------------------------------------------- -! intcartderiv.F -!----------------------------------------------------------------------------- - subroutine intcartderiv -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.LOCAL' -! include 'COMMON.SCCOR' - real(kind=8) :: pi4,pi34 - real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres) - real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,& - dcosomega,dsinomega !(3,3,maxres) - real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n - - integer :: i,j,k - real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,& - fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,& - fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,& - fac17,coso_inv,fac10,fac11,fac12,fac13,fac14 - integer :: nres2 - nres2=2*nres - -!el from module energy------------- -!el allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres -!el allocate(dsintau(3,3,3,itau_start:itau_end)) -!el allocate(dtauangle(3,3,3,itau_start:itau_end)) - -!el allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres -!el allocate(dsintau(3,3,3,0:nres2)) -!el allocate(dtauangle(3,3,3,0:nres2)) -!el allocate(domicron(3,2,2,0:nres2)) -!el allocate(dcosomicron(3,2,2,0:nres2)) - - - -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1 .and. me.eq.king) & - call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - pi4 = 0.5d0*pipol - pi34 = 3*pi4 - -! allocate(dtheta(3,2,nres)) !(3,2,maxres) -! allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres) - -! write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end - do i=1,nres - do j=1,3 - dtheta(j,1,i)=0.0d0 - dtheta(j,2,i)=0.0d0 - dphi(j,1,i)=0.0d0 - dphi(j,2,i)=0.0d0 - dphi(j,3,i)=0.0d0 - enddo - enddo -! Derivatives of theta's -#if defined(MPI) && defined(PARINTDER) -! We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - cost=dcos(theta(i)) - sint=sqrt(1-cost*cost) - do j=1,3 - dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/& - vbld(i-1) - if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint - dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/& - vbld(i) - if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint - enddo - enddo -#if defined(MPI) && defined(PARINTDER) -! We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then - cost1=dcos(omicron(1,i)) - sint1=sqrt(1-cost1*cost1) - cost2=dcos(omicron(2,i)) - sint2=sqrt(1-cost2*cost2) - do j=1,3 -!C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1) - dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ & - cost1*dc_norm(j,i-2))/ & - vbld(i-1) - domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i) - dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) & - +cost1*(dc_norm(j,i-1+nres)))/ & - vbld(i-1+nres) - domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i) -!C Calculate derivative over second omicron Sci-1,Cai-1 Cai -!C Looks messy but better than if in loop - dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) & - +cost2*dc_norm(j,i-1))/ & - vbld(i) - domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i) - dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) & - +cost2*(-dc_norm(j,i-1+nres)))/ & - vbld(i-1+nres) -! write(iout,*) "vbld", i,itype(i),vbld(i-1+nres) - domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i) - enddo - endif - enddo -!elwrite(iout,*) "after vbld write" -! Derivatives of phi: -! If phi is 0 or 180 degrees, then the formulas -! have to be derived by power series expansion of the -! conventional formulas around 0 and 180. -#ifdef PARINTDER - do i=iphi1_start,iphi1_end -#else - do i=4,nres -#endif -! if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle -! the conventional case - sint=dsin(theta(i)) - sint1=dsin(theta(i-1)) - sing=dsin(phi(i)) - cost=dcos(theta(i)) - cost1=dcos(theta(i-1)) - cosg=dcos(phi(i)) - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -! Obtaining the gamma derivatives from sine derivative - if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. & - phi(i).gt.pi34.and.phi(i).le.pi.or. & - phi(i).gt.-pi.and.phi(i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then - dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) & - -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) - dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) - dsinphi(j,2,i)= & - -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) & - -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) - dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) & - +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) - endif -! Bug fixed 3/24/05 (AL) - enddo -! Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then - dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* & - dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* & - dc_norm(j,i-3))/vbld(i-2) - dphi(j,1,i)=-1/sing*dcosphi(j,1,i) - dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* & - dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* & - dcostheta(j,1,i) - dphi(j,2,i)=-1/sing*dcosphi(j,2,i) - dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* & - dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* & - dc_norm(j,i-1))/vbld(i) - dphi(j,3,i)=-1/sing*dcosphi(j,3,i) - endif - enddo - endif - enddo -!alculate derivative of Tauangle -#ifdef PARINTDER - do i=itau_start,itau_end -#else - do i=3,nres -!elwrite(iout,*) " vecpr",i,nres -#endif - if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle -! if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or. -! & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle -!c dtauangle(j,intertyp,dervityp,residue number) -!c INTERTYP=1 SC...Ca...Ca..Ca -! the conventional case - sint=dsin(theta(i)) - sint1=dsin(omicron(2,i-1)) - sing=dsin(tauangle(1,i)) - cost=dcos(theta(i)) - cost1=dcos(omicron(2,i-1)) - cosg=dcos(tauangle(1,i)) -!elwrite(iout,*) " vecpr5",i,nres - do j=1,3 -!elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres -!elwrite(iout,*) " vecpr5",dc_norm2(1,1) - dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) -! write(iout,*) dc_norm2(j,i-2+nres),"dcnorm" - enddo - scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -! write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4 -! Obtaining the gamma derivatives from sine derivative - if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. & - tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. & - tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) & - -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) & - *vbld_inv(i-2+nres) - dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i) - dsintau(j,1,2,i)= & - -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) & - -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) -! write(iout,*) "dsintau", dsintau(j,1,2,i) - dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i) -! Bug fixed 3/24/05 (AL) - dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) & - +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i) - enddo -! Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* & - dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* & - (dc_norm2(j,i-2+nres)))/vbld(i-2+nres) - dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i) - dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* & - dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* & - dcostheta(j,1,i) - dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i) - dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* & - dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* & - dc_norm(j,i-1))/vbld(i) - dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i) -! write (iout,*) "else",i - enddo - endif -! do k=1,3 -! write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3) -! enddo - enddo -!C Second case Ca...Ca...Ca...SC -#ifdef PARINTDER - do i=itau_start,itau_end -#else - do i=4,nres -#endif - if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. & - (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle -! the conventional case - sint=dsin(omicron(1,i)) - sint1=dsin(theta(i-1)) - sing=dsin(tauangle(2,i)) - cost=dcos(omicron(1,i)) - cost1=dcos(theta(i-1)) - cosg=dcos(tauangle(2,i)) -! do j=1,3 -! dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) -! enddo - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -! Obtaining the gamma derivatives from sine derivative - if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. & - tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. & - tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then - call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) & - +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2) -! write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1), -! &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)" - dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i) - dsintau(j,2,2,i)= & - -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) & - -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) -! write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1), -! & sing*ctgt*domicron(j,1,2,i), -! & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i) -! Bug fixed 3/24/05 (AL) - dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) & - +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres) -! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i) - enddo -! Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* & - dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* & - dc_norm(j,i-3))/vbld(i-2) - dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i) - dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* & - dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* & - dcosomicron(j,1,1,i) - dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i) - dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* & - dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* & - dc_norm(j,i-1+nres))/vbld(i-1+nres) - dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i) -! write(iout,*) i,j,"else", dtauangle(j,2,3,i) - enddo - endif - enddo - -!CC third case SC...Ca...Ca...SC -#ifdef PARINTDER - - do i=itau_start,itau_end -#else - do i=3,nres -#endif -! the conventional case - if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. & - (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle - sint=dsin(omicron(1,i)) - sint1=dsin(omicron(2,i-1)) - sing=dsin(tauangle(3,i)) - cost=dcos(omicron(1,i)) - cost1=dcos(omicron(2,i-1)) - cosg=dcos(tauangle(3,i)) - do j=1,3 - dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) -! dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) - enddo - scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -! Obtaining the gamma derivatives from sine derivative - if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. & - tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. & - tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then - call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) & - -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) & - *vbld_inv(i-2+nres) - dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i) - dsintau(j,3,2,i)= & - -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) & - -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i) -! Bug fixed 3/24/05 (AL) - dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) & - +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) & - *vbld_inv(i-1+nres) -! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i) - enddo -! Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* & - dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* & - dc_norm2(j,i-2+nres))/vbld(i-2+nres) - dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i) - dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* & - dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* & - dcosomicron(j,1,1,i) - dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i) - dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* & - dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* & - dc_norm(j,i-1+nres))/vbld(i-1+nres) - dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i) -! write(iout,*) "else",i - enddo - endif - enddo - -#ifdef CRYST_SC -! Derivatives of side-chain angles alpha and omega -#if defined(MPI) && defined(PARINTDER) - do i=ibond_start,ibond_end -#else - do i=2,nres-1 -#endif - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) - fac6=fac5/vbld(i) - fac7=fac5*fac5 - fac8=fac5/vbld(i+1) - fac9=fac5/vbld(i+nres) - scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* & - (scalar(dC_norm(1,i),dC_norm(1,i+nres)) & - -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) - sina=sqrt(1-cosa*cosa) - sino=dsin(omeg(i)) -! write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino - do j=1,3 - dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- & - dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) - dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) - dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- & - scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) - dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) - dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- & - dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ & - vbld(i+nres)) - dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) - enddo -! obtaining the derivatives of omega from sines - if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. & - omeg(i).gt.pi34.and.omeg(i).le.pi.or. & - omeg(i).gt.-pi.and.omeg(i).le.-pi34) then - fac15=dcos(theta(i+1))/(dsin(theta(i+1))* & - dsin(theta(i+1))) - fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) - fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) - call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) - coso_inv=1.0d0/dcos(omeg(i)) - do j=1,3 - dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) & - +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- & - (sino*dc_norm(j,i-1))/vbld(i) - domega(j,1,i)=coso_inv*dsinomega(j,1,i) - dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) & - +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) & - -sino*dc_norm(j,i)/vbld(i+1) - domega(j,2,i)=coso_inv*dsinomega(j,2,i) - dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- & - fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ & - vbld(i+nres) - domega(j,3,i)=coso_inv*dsinomega(j,3,i) - enddo - else -! obtaining the derivatives of omega from cosines - fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) - fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) - fac12=fac10*sina - fac13=fac12*fac12 - fac14=sina*sina - do j=1,3 - dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* & - dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ & - (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* & - fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 - domega(j,1,i)=-1/sino*dcosomega(j,1,i) - dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* & - dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* & - dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ & - (scala2-fac11*cosa)*(0.25d0*sina/fac10* & - dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13 - domega(j,2,i)=-1/sino*dcosomega(j,2,i) - dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- & - scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ & - (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 - domega(j,3,i)=-1/sino*dcosomega(j,3,i) - enddo - endif - else - do j=1,3 - do k=1,3 - dalpha(k,j,i)=0.0d0 - domega(k,j,i)=0.0d0 - enddo - enddo - endif - enddo -#endif -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1) then -#ifdef DEBUG -!d write (iout,*) "Gather dtheta" -!d call flush(iout) - write (iout,*) "dtheta before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) - enddo -#endif - call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),& - MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,& - king,FG_COMM,IERROR) -#ifdef DEBUG -!d write (iout,*) "Gather dphi" -!d call flush(iout) - write (iout,*) "dphi before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) - enddo -#endif - call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),& - MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,& - king,FG_COMM,IERROR) -!d write (iout,*) "Gather dalpha" -!d call flush(iout) -#ifdef CRYST_SC - call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),& - MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,& - king,FG_COMM,IERROR) -!d write (iout,*) "Gather domega" -!d call flush(iout) - call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),& - MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,& - king,FG_COMM,IERROR) -#endif - endif -#endif -#ifdef DEBUG - write (iout,*) "dtheta after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2) - enddo - write (iout,*) "dphi after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) - enddo - write (iout,*) "dalpha after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3) - enddo - write (iout,*) "domega after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3) - enddo -#endif - return - end subroutine intcartderiv -!----------------------------------------------------------------------------- - subroutine checkintcartgrad -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.SETUP' - real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres) - real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres) - real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres) - real(kind=8),dimension(3) :: dc_norm_s - real(kind=8) :: aincr=1.0d-5 - integer :: i,j - real(kind=8) :: dcji - do i=1,nres - phi_s(i)=phi(i) - theta_s(i)=theta(i) - alph_s(i)=alph(i) - omeg_s(i)=omeg(i) - enddo -! Check theta gradient - write (iout,*) & - "Analytical (upper) and numerical (lower) gradient of theta" - write (iout,*) - do i=3,nres - do j=1,3 - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - call int_from_cart1(.false.) - dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-1)=dcji - enddo -!el write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),& -!el (dtheta(j,2,i),j=1,3) -!el write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),& -!el (dthetanum(j,2,i),j=1,3) -!el write (iout,'(5x,3f10.5,5x,3f10.5)') & -!el (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),& -!el (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) -!el write (iout,*) - enddo -! Check gamma gradient - write (iout,*) & - "Analytical (upper) and numerical (lower) gradient of gamma" - do i=4,nres - do j=1,3 - dcji=dc(j,i-3) - dc(j,i-3)=dcji+aincr - call chainbuild_cart - dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-3)=dcji - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-1)=dcji - enddo -!el write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),& -!el (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) -!el write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),& -!el (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) -!el write (iout,'(5x,3(3f10.5,5x))') & -!el (dphinum(j,1,i)/dphi(j,1,i),j=1,3),& -!el (dphinum(j,2,i)/dphi(j,2,i),j=1,3),& -!el (dphinum(j,3,i)/dphi(j,3,i),j=1,3) -!el write (iout,*) - enddo -! Check alpha gradient - write (iout,*) & - "Analytical (upper) and numerical (lower) gradient of alpha" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - dalphanum(j,1,i)=(alph(i)-alph_s(i)) & - /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - dalphanum(j,2,i)=(alph(i)-alph_s(i)) & - /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - dalphanum(j,3,i)=(alph(i)-alph_s(i)) & - /aincr - dc(j,i+nres)=dcji - enddo - endif -!el write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),& -!el (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) -!el write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),& -!el (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) -!el write (iout,'(5x,3(3f10.5,5x))') & -!el (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),& -!el (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),& -!el (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) -!el write (iout,*) - enddo -! Check omega gradient - write (iout,*) & - "Analytical (upper) and numerical (lower) gradient of omega" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - domeganum(j,1,i)=(omeg(i)-omeg_s(i)) & - /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - domeganum(j,2,i)=(omeg(i)-omeg_s(i)) & - /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - domeganum(j,3,i)=(omeg(i)-omeg_s(i)) & - /aincr - dc(j,i+nres)=dcji - enddo - endif -!el write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),& -!el (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) -!el write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),& -!el (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) -!el write (iout,'(5x,3(3f10.5,5x))') & -!el (domeganum(j,1,i)/domega(j,1,i),j=1,3),& -!el (domeganum(j,2,i)/domega(j,2,i),j=1,3),& -!el (domeganum(j,3,i)/domega(j,3,i),j=1,3) -!el write (iout,*) - enddo - return - end subroutine checkintcartgrad -!----------------------------------------------------------------------------- -! q_measure.F -!----------------------------------------------------------------------------- - real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' - integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg - integer :: kkk,nsep=3 - real(kind=8) :: qm !dist, - real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax - logical :: lprn=.false. - logical :: flag -! real(kind=8) :: sigm,x - -!el sigm(x)=0.25d0*x ! local function - qqmax=1.0d10 - do kkk=1,nperm - qq = 0.0d0 - nl=0 - if(flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + & - (cref(2,jl,kkk)-cref(2,il,kkk))**2 + & - (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - enddo - enddo - qq = qq/nl - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & - (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & - (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - enddo - enddo - qq = qq/nl - endif - if (qqmax.le.qq) qqmax=qq - enddo - qwolynes=1.0d0-qqmax - return - end function qwolynes -!----------------------------------------------------------------------------- - subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.MD' - integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg - integer :: nsep=3, kkk -!el real(kind=8) :: dist - real(kind=8) :: dij,d0ij,dijCM,d0ijCM - logical :: lprn=.false. - logical :: flag - real(kind=8) :: sim,dd0,fac,ddqij -!el sigm(x)=0.25d0*x ! local function - do kkk=1,nperm - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - nl=0 - if(flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & - (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & - (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - sim = 1.0d0/sigm(d0ij) - sim = sim*sim - dd0 = dij-d0ij - fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - sim = 1.0d0/sigm(d0ijCM) - sim = sim*sim - dd0=dijCM-d0ijCM - fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il+nres)-c(k,jl+nres))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - enddo - enddo - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & - (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & - (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - sim = 1.0d0/sigm(d0ij) - sim = sim*sim - dd0 = dij-d0ij - fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - sim = 1.0d0/sigm(d0ijCM) - sim=sim*sim - dd0 = dijCM-d0ijCM - fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il+nres)-c(k,jl+nres))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - enddo - enddo - endif - enddo - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end subroutine qwolynes_prim -!----------------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' - integer :: seg1,seg2,seg3,seg4 - logical :: flag - real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan - real(kind=8),dimension(3,0:2*nres) :: cdummy - real(kind=8) :: q1,q2 - real(kind=8) :: delta=1.0d-10 - integer :: i,j - - do i=0,nres - do j=1,3 - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=(q2-q1)/delta - c(j,i)=cdummy(j,i) - enddo - enddo - do i=0,nres - do j=1,3 - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo -! write(iout,*) "Numerical Q carteisan gradients backbone: " -! do i=0,nct -! write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) -! enddo -! write(iout,*) "Numerical Q carteisan gradients side-chain: " -! do i=0,nct -! write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) -! enddo - return - end subroutine qwol_num -!----------------------------------------------------------------------------- - subroutine EconstrQ -! MD with umbrella_sampling using Wolyne's distance measure as a constraint -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' - use MD_data -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan - real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,& - duconst,duxconst - integer :: kstart,kend,lstart,lend,idummy - real(kind=8) :: delta=1.0d-7 - integer :: i,j,k,ii - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,& - idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -! Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),& - qinfrag(i,iset)) -! hm1=harmonic(qfrag(i,iset),qinfrag(i,iset)) -! hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset)) -! hmnum=(hm2-hm1)/delta -! write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset), -! & qinfrag(i,iset)) -! write(iout,*) "harmonicnum frag", hmnum -! Calculating the derivatives of Q with respect to cartesian coordinates - call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,& - idummy,idummy) -! write(iout,*) "dqwol " -! do ii=1,nres -! write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) -! enddo -! write(iout,*) "dxqwol " -! do ii=1,nres -! write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) -! enddo -! Calculating numerical gradients of dU/dQi and dQi/dxi -! call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. -! & ,idummy,idummy) -! The gradients of Uconst in Cs - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo - enddo - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -! Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -! hm1=harmonic(qpair(i),qinpair(i,iset)) -! hm2=harmonic(qpair(i)+delta,qinpair(i,iset)) -! hmnum=(hm2-hm1)/delta -! write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i), -! & qinpair(i,iset)) -! write(iout,*) "harmonicnum pair ", hmnum -! Calculating dQ/dXi - call qwolynes_prim(kstart,kend,.false.,& - lstart,lend) -! write(iout,*) "dqwol " -! do ii=1,nres -! write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) -! enddo -! write(iout,*) "dxqwol " -! do ii=1,nres -! write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) -! enddo -! Calculating numerical gradients -! call qwol_num(kstart,kend,.false. -! & ,lstart,lend) -! The gradients of Uconst in Cs - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -! write(iout,*) "Uconst inside subroutine ", Uconst -! Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -! Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -! write(iout,*) "dU/ddc backbone " -! do ii=0,nres -! write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -! enddo -! write(iout,*) "dU/ddX side chain " -! do ii=1,nres -! write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -! enddo -! Calculating numerical gradients of dUconst/ddc and dUconst/ddx -! call dEconstrQ_num - return - end subroutine EconstrQ -!----------------------------------------------------------------------------- - subroutine dEconstrQ_num -! Calculating numerical dUconst/ddc and dUconst/ddx -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.VAR' -! include 'COMMON.MD' - use MD_data -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.TIME1' - real(kind=8) :: uzap1,uzap2 - real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy - integer :: kstart,kend,lstart,lend,idummy - real(kind=8) :: delta=1.0d-7 -!el local variables - integer :: i,ii,j -! real(kind=8) :: -! For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& - idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),& - qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),& - qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& - idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),& - qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),& - qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -! Calculating numerical gradients for dU/ddx - do i=0,nres-1 - duxcartan(j,i)=0.0d0 - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& - idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),& - qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),& - qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),& - ifrag(2,ii,iset),.true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),& - qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),& - qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo -! write(iout,*) "Numerical dUconst/ddx side-chain " -! do ii=1,nres -! write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) -! enddo - return - end subroutine dEconstrQ_num -!----------------------------------------------------------------------------- -! ssMD.F -!----------------------------------------------------------------------------- - subroutine check_energies - -! use random, only: ran_number - -! implicit none -! Includes -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.SBRIDGE' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' - -! External functions -!EL double precision ran_number -!EL external ran_number - -! Local variables - integer :: i,j,k,l,lmax,p,pmax - real(kind=8) :: rmin,rmax - real(kind=8) :: eij - - real(kind=8) :: d - real(kind=8) :: wi,rij,tj,pj -! return - - i=5 - j=14 - - d=dsc(1) - rmin=2.0D0 - rmax=12.0D0 - - lmax=10000 - pmax=1 - - do k=1,3 - c(k,i)=0.0D0 - c(k,j)=0.0D0 - c(k,nres+i)=0.0D0 - c(k,nres+j)=0.0D0 - enddo - - do l=1,lmax - -!t wi=ran_number(0.0D0,pi) -! wi=ran_number(0.0D0,pi/6.0D0) -! wi=0.0D0 -!t tj=ran_number(0.0D0,pi) -!t pj=ran_number(0.0D0,pi) -! pj=ran_number(0.0D0,pi/6.0D0) -! pj=0.0D0 - - do p=1,pmax -!t rij=ran_number(rmin,rmax) - - c(1,j)=d*sin(pj)*cos(tj) - c(2,j)=d*sin(pj)*sin(tj) - c(3,j)=d*cos(pj) - - c(3,nres+i)=-rij - - c(1,i)=d*sin(wi) - c(3,i)=-rij-d*cos(wi) - - do k=1,3 - dc(k,nres+i)=c(k,nres+i)-c(k,i) - dc_norm(k,nres+i)=dc(k,nres+i)/d - dc(k,nres+j)=c(k,nres+j)-c(k,j) - dc_norm(k,nres+j)=dc(k,nres+j)/d - enddo - - call dyn_ssbond_ene(i,j,eij) - enddo - enddo - call exit(1) - return - end subroutine check_energies -!----------------------------------------------------------------------------- - subroutine dyn_ssbond_ene(resi,resj,eij) -! implicit none -! Includes - use calc_data - use comm_sschecks -! include 'DIMENSIONS' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' -#ifndef CLUST -#ifndef WHAM - use MD_data -! include 'COMMON.MD' -! use MD, only: totT,t_bath -#endif -#endif -! External functions -!EL double precision h_base -!EL external h_base - -! Input arguments - integer :: resi,resj - -! Output arguments - real(kind=8) :: eij - -! Local variables - logical :: havebond - integer itypi,itypj - real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi - real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2 - real(kind=8),dimension(3) :: dcosom1,dcosom2 - real(kind=8) :: ed - real(kind=8) :: pom1,pom2 - real(kind=8) :: ljA,ljB,ljXs - real(kind=8),dimension(1:3) :: d_ljB - real(kind=8) :: ssA,ssB,ssC,ssXs - real(kind=8) :: ssxm,ljxm,ssm,ljm - real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm - real(kind=8) :: f1,f2,h1,h2,hd1,hd2 - real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2 -!-------FIRST METHOD - real(kind=8) :: xm - real(kind=8),dimension(1:3) :: d_xm -!-------END FIRST METHOD -!-------SECOND METHOD -!$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) -!-------END SECOND METHOD - -!-------TESTING CODE -!el logical :: checkstop,transgrad -!el common /sschecks/ checkstop,transgrad - - integer :: icheck,nicheck,jcheck,njcheck - real(kind=8),dimension(-1:1) :: echeck - real(kind=8) :: deps,ssx0,ljx0 -!-------END TESTING CODE - - eij=0.0d0 - i=resi - j=resj - -!el allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres)) -!el allocate(dyn_ssbond_ij(0:nres+4,nres)) - - itypi=itype(i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=vbld_inv(i+nres) - - itypj=itype(j) - xj=c(1,nres+j)-c(1,nres+i) - yj=c(2,nres+j)-c(2,nres+i) - zj=c(3,nres+j)-c(3,nres+i) - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - dscj_inv=vbld_inv(j+nres) - - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse -! The following are set in sc_angular -! erij(1)=xj*rij -! erij(2)=yj*rij -! erij(3)=zj*rij -! om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) -! om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) -! om12=dxi*dxj+dyi*dyj+dzi*dzj - call sc_angular - rij=1.0D0/rij ! Reset this so it makes sense - - sig0ij=sigma(itypi,itypj) - sig=sig0ij*dsqrt(1.0D0/sigsq) - - ljXs=sig-sig0ij - ljA=eps1*eps2rt**2*eps3rt**2 - ljB=ljA*bb(itypi,itypj) - ljA=ljA*aa(itypi,itypj) - ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - - ssXs=d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - ssA=akcm - ssB=akct*deltat12 - ssC=ss_depth & - +akth*(deltat1*deltat1+deltat2*deltat2) & - +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi - ssxm=ssXs-0.5D0*ssB/ssA - -!-------TESTING CODE -!$$$c Some extra output -!$$$ ssm=ssC-0.25D0*ssB*ssB/ssA -!$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) -!$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC -!$$$ if (ssx0.gt.0.0d0) then -!$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA -!$$$ else -!$$$ ssx0=ssxm -!$$$ endif -!$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -!$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", -!$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 -!$$$ return -!-------END TESTING CODE - -!-------TESTING CODE -! Stop and plot energy and derivative as a function of distance - if (checkstop) then - ssm=ssC-0.25D0*ssB*ssB/ssA - ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) - if (ssm.lt.ljm .and. & - dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then - nicheck=1000 - njcheck=1 - deps=0.5d-7 - else - checkstop=.false. - endif - endif - if (.not.checkstop) then - nicheck=0 - njcheck=-1 - endif - - do icheck=0,nicheck - do jcheck=-1,njcheck - if (checkstop) rij=(ssxm-1.0d0)+ & - ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps -!-------END TESTING CODE - - if (rij.gt.ljxm) then - havebond=.false. - ljd=rij-ljXs - fac=(1.0D0/ljd)**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - eij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=eij*eps3rt - eps3der=eij*eps2rt - eij=eij*eps2rt*eps3rt - - sigder=-sig/sigsq - e1=e1*eps1*eps2rt**2*eps3rt**2 - ed=-expon*(e1+eij)/ljd - sigder=ed*sigder - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=eij*eps1_om12+eps2der*eps2rt_om12 & - -2.0D0*alf12*eps3der+sigder*sigsq_om12 - else if (rij.lt.ssxm) then - havebond=.true. - ssd=rij-ssXs - eij=ssA*ssd*ssd+ssB*ssd+ssC - - ed=2*akcm*ssd+akct*deltat12 - pom1=akct*ssd - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - else - omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi - - d_ssxm(1)=0.5D0*akct/ssA - d_ssxm(2)=-d_ssxm(1) - d_ssxm(3)=0.0D0 - - d_ljxm(1)=sig0ij/sqrt(sigsq**3) - d_ljxm(2)=d_ljxm(1)*sigsq_om2 - d_ljxm(3)=d_ljxm(1)*sigsq_om12 - d_ljxm(1)=d_ljxm(1)*sigsq_om1 - -!-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE - xm=0.5d0*(ssxm+ljxm) - do k=1,3 - d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) - enddo - if (rij.lt.xm) then - havebond=.true. - ssm=ssC-0.25D0*ssB*ssB/ssA - d_ssm(1)=0.5D0*akct*ssB/ssA - d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) - d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) - d_ssm(3)=omega - f1=(rij-xm)/(ssxm-xm) - f2=(rij-ssxm)/(xm-ssxm) - h1=h_base(f1,hd1) - h2=h_base(f2,hd2) - eij=ssm*h1+Ht*h2 - delta_inv=1.0d0/(xm-ssxm) - deltasq_inv=delta_inv*delta_inv - fac=ssm*hd1-Ht*hd2 - fac1=deltasq_inv*fac*(xm-rij) - fac2=deltasq_inv*fac*(rij-ssxm) - ed=delta_inv*(Ht*hd2-ssm*hd1) - eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) - eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) - eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) - else - havebond=.false. - ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) - d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB - d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) - d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- & - alf12/eps3rt) - d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) - f1=(rij-ljxm)/(xm-ljxm) - f2=(rij-xm)/(ljxm-xm) - h1=h_base(f1,hd1) - h2=h_base(f2,hd2) - eij=Ht*h1+ljm*h2 - delta_inv=1.0d0/(ljxm-xm) - deltasq_inv=delta_inv*delta_inv - fac=Ht*hd1-ljm*hd2 - fac1=deltasq_inv*fac*(ljxm-rij) - fac2=deltasq_inv*fac*(rij-xm) - ed=delta_inv*(ljm*hd2-Ht*hd1) - eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) - eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) - eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) - endif -!-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE - -!-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE -!$$$ ssd=rij-ssXs -!$$$ ljd=rij-ljXs -!$$$ fac1=rij-ljxm -!$$$ fac2=rij-ssxm -!$$$ -!$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) -!$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) -!$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) -!$$$ -!$$$ ssm=ssC-0.25D0*ssB*ssB/ssA -!$$$ d_ssm(1)=0.5D0*akct*ssB/ssA -!$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) -!$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) -!$$$ d_ssm(3)=omega -!$$$ -!$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) -!$$$ do k=1,3 -!$$$ d_ljm(k)=ljm*d_ljB(k) -!$$$ enddo -!$$$ ljm=ljm*ljB -!$$$ -!$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC -!$$$ d_ss(0)=2.0d0*ssA*ssd+ssB -!$$$ d_ss(2)=akct*ssd -!$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega -!$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega -!$$$ d_ss(3)=omega -!$$$ -!$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) -!$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) -!$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 -!$$$ do k=1,3 -!$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- -!$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) -!$$$ enddo -!$$$ ljf=ljm+ljf*ljB*fac1*fac1 -!$$$ -!$$$ f1=(rij-ljxm)/(ssxm-ljxm) -!$$$ f2=(rij-ssxm)/(ljxm-ssxm) -!$$$ h1=h_base(f1,hd1) -!$$$ h2=h_base(f2,hd2) -!$$$ eij=ss*h1+ljf*h2 -!$$$ delta_inv=1.0d0/(ljxm-ssxm) -!$$$ deltasq_inv=delta_inv*delta_inv -!$$$ fac=ljf*hd2-ss*hd1 -!$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac -!$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* -!$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) -!$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* -!$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) -!$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* -!$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) -!$$$ -!$$$ havebond=.false. -!$$$ if (ed.gt.0.0d0) havebond=.true. -!-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE - - endif - - if (havebond) then -!#ifndef CLUST -!#ifndef WHAM -! if (dyn_ssbond_ij(i,j).eq.1.0d300) then -! write(iout,'(a15,f12.2,f8.1,2i5)') -! & "SSBOND_E_FORM",totT,t_bath,i,j -! endif -!#endif -!#endif - dyn_ssbond_ij(i,j)=eij - else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then - dyn_ssbond_ij(i,j)=1.0d300 -!#ifndef CLUST -!#ifndef WHAM -! write(iout,'(a15,f12.2,f8.1,2i5)') -! & "SSBOND_E_BREAK",totT,t_bath,i,j -!#endif -!#endif - endif - -!-------TESTING CODE -!el if (checkstop) then - if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') & - "CHECKSTOP",rij,eij,ed - echeck(jcheck)=eij -!el endif - enddo - if (checkstop) then - write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps - endif - enddo - if (checkstop) then - transgrad=.true. - checkstop=.false. - endif -!-------END TESTING CODE - - do k=1,3 - dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij - dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij - enddo - do k=1,3 - gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - enddo - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) & - +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & - +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - gvdwx(k,j)=gvdwx(k,j)+gg(k) & - +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & - +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -!grad do k=i,j-1 -!grad do l=1,3 -!grad gvdwc(l,k)=gvdwc(l,k)+gg(l) -!grad enddo -!grad enddo - - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - - return - end subroutine dyn_ssbond_ene -!----------------------------------------------------------------------------- - real(kind=8) function h_base(x,deriv) -! A smooth function going 0->1 in range [0,1] -! It should NOT be called outside range [0,1], it will not work there. - implicit none - -! Input arguments - real(kind=8) :: x - -! Output arguments - real(kind=8) :: deriv - -! Local variables - real(kind=8) :: xsq - - -! Two parabolas put together. First derivative zero at extrema -!$$$ if (x.lt.0.5D0) then -!$$$ h_base=2.0D0*x*x -!$$$ deriv=4.0D0*x -!$$$ else -!$$$ deriv=1.0D0-x -!$$$ h_base=1.0D0-2.0D0*deriv*deriv -!$$$ deriv=4.0D0*deriv -!$$$ endif - -! Third degree polynomial. First derivative zero at extrema - h_base=x*x*(3.0d0-2.0d0*x) - deriv=6.0d0*x*(1.0d0-x) - -! Fifth degree polynomial. First and second derivatives zero at extrema -!$$$ xsq=x*x -!$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) -!$$$ deriv=x-1.0d0 -!$$$ deriv=deriv*deriv -!$$$ deriv=30.0d0*xsq*deriv - - return - end function h_base -!----------------------------------------------------------------------------- - subroutine dyn_set_nss -! Adjust nss and other relevant variables based on dyn_ssbond_ij -! implicit none - use MD_data, only: totT,t_bath -! Includes -! include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.SETUP' -! include 'COMMON.MD' -! Local variables - real(kind=8) :: emin - integer :: i,j,imin,ierr - integer :: diff,allnss,newnss - integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) - newihpb,newjhpb - logical :: found - integer,dimension(0:nfgtasks) :: i_newnss - integer,dimension(0:nfgtasks) :: displ - integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) - integer :: g_newnss - - allnss=0 - do i=1,nres-1 - do j=i+1,nres - if (dyn_ssbond_ij(i,j).lt.1.0d300) then - allnss=allnss+1 - allflag(allnss)=0 - allihpb(allnss)=i - alljhpb(allnss)=j - endif - enddo - enddo - -!mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) - - 1 emin=1.0d300 - do i=1,allnss - if (allflag(i).eq.0 .and. & - dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then - emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) - imin=i - endif - enddo - if (emin.lt.1.0d300) then - allflag(imin)=1 - do i=1,allnss - if (allflag(i).eq.0 .and. & - (allihpb(i).eq.allihpb(imin) .or. & - alljhpb(i).eq.allihpb(imin) .or. & - allihpb(i).eq.alljhpb(imin) .or. & - alljhpb(i).eq.alljhpb(imin))) then - allflag(i)=-1 - endif - enddo - goto 1 - endif - -!mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) - - newnss=0 - do i=1,allnss - if (allflag(i).eq.1) then - newnss=newnss+1 - newihpb(newnss)=allihpb(i) - newjhpb(newnss)=alljhpb(i) - endif - enddo - -#ifdef MPI - if (nfgtasks.gt.1)then - - call MPI_Reduce(newnss,g_newnss,1,& - MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) - call MPI_Gather(newnss,1,MPI_INTEGER,& - i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) - displ(0)=0 - do i=1,nfgtasks-1,1 - displ(i)=i_newnss(i-1)+displ(i-1) - enddo - call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,& - g_newihpb,i_newnss,displ,MPI_INTEGER,& - king,FG_COMM,IERR) - call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,& - g_newjhpb,i_newnss,displ,MPI_INTEGER,& - king,FG_COMM,IERR) - if(fg_rank.eq.0) then -! print *,'g_newnss',g_newnss -! print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) -! print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) - newnss=g_newnss - do i=1,newnss - newihpb(i)=g_newihpb(i) - newjhpb(i)=g_newjhpb(i) - enddo - endif - endif -#endif - - diff=newnss-nss - -!mc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) - - do i=1,nss - found=.false. - do j=1,newnss - if (idssb(i).eq.newihpb(j) .and. & - jdssb(i).eq.newjhpb(j)) found=.true. - enddo -#ifndef CLUST -#ifndef WHAM - if (.not.found.and.fg_rank.eq.0) & - write(iout,'(a15,f12.2,f8.1,2i5)') & - "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) -#endif -#endif - enddo - - do i=1,newnss - found=.false. - do j=1,nss - if (newihpb(i).eq.idssb(j) .and. & - newjhpb(i).eq.jdssb(j)) found=.true. - enddo -#ifndef CLUST -#ifndef WHAM - if (.not.found.and.fg_rank.eq.0) & - write(iout,'(a15,f12.2,f8.1,2i5)') & - "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) -#endif -#endif - enddo - - nss=newnss - do i=1,nss - idssb(i)=newihpb(i) - jdssb(i)=newjhpb(i) - enddo - - return - end subroutine dyn_set_nss -!----------------------------------------------------------------------------- -#ifdef WHAM - subroutine read_ssHist -! implicit none -! Includes -! include 'DIMENSIONS' -! include "DIMENSIONS.FREE" -! include 'COMMON.FREE' -! Local variables - integer :: i,j - character(len=80) :: controlcard - - do i=1,dyn_nssHist - call card_concat(controlcard,.true.) - read(controlcard,*) & - dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) - enddo - - return - end subroutine read_ssHist -#endif -!----------------------------------------------------------------------------- - integer function indmat(i,j) -!el -! get the position of the jth ijth fragment of the chain coordinate system -! in the fromto array. - integer :: i,j - - indmat=((2*(nres-2)-i)*(i-1))/2+j-1 - return - end function indmat -!----------------------------------------------------------------------------- - real(kind=8) function sigm(x) -!el - real(kind=8) :: x - sigm=0.25d0*x - return - end function sigm -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - subroutine alloc_ener_arrays -!EL Allocation of arrays used by module energy - -!el local variables - integer :: i,j - - if(nres.lt.100) then - maxconts=nres - elseif(nres.lt.200) then - maxconts=0.8*nres ! Max. number of contacts per residue - else - maxconts=0.6*nres ! (maxconts=maxres/4) - endif - maxcont=12*nres ! Max. number of SC contacts - maxvar=6*nres ! Max. number of variables -!el maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond - maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond -!---------------------- -! arrays in subroutine init_int_table -!el#ifdef MPI -!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) -!el#endif - allocate(nint_gr(nres)) - allocate(nscp_gr(nres)) - allocate(ielstart(nres)) - allocate(ielend(nres)) -!(maxres) - allocate(istart(nres,maxint_gr)) - allocate(iend(nres,maxint_gr)) -!(maxres,maxint_gr) - allocate(iscpstart(nres,maxint_gr)) - allocate(iscpend(nres,maxint_gr)) -!(maxres,maxint_gr) - allocate(ielstart_vdw(nres)) - allocate(ielend_vdw(nres)) -!(maxres) - - allocate(lentyp(0:nfgtasks-1)) -!(0:maxprocs-1) -!---------------------- -! commom.contacts -! common /contacts/ - if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont)) - allocate(icont(2,maxcont)) -!(2,maxcont) -! common /contacts1/ - allocate(num_cont(0:nres+4)) -!(maxres) - allocate(jcont(maxconts,nres)) -!(maxconts,maxres) - allocate(facont(maxconts,nres)) -!(maxconts,maxres) - allocate(gacont(3,maxconts,nres)) -!(3,maxconts,maxres) -! common /contacts_hb/ - allocate(gacontp_hb1(3,maxconts,nres)) - allocate(gacontp_hb2(3,maxconts,nres)) - allocate(gacontp_hb3(3,maxconts,nres)) - allocate(gacontm_hb1(3,maxconts,nres)) - allocate(gacontm_hb2(3,maxconts,nres)) - allocate(gacontm_hb3(3,maxconts,nres)) - allocate(gacont_hbr(3,maxconts,nres)) - allocate(grij_hb_cont(3,maxconts,nres)) -!(3,maxconts,maxres) - allocate(facont_hb(maxconts,nres)) - allocate(ees0p(maxconts,nres)) - allocate(ees0m(maxconts,nres)) - allocate(d_cont(maxconts,nres)) -!(maxconts,maxres) - allocate(num_cont_hb(nres)) -!(maxres) - allocate(jcont_hb(maxconts,nres)) -!(maxconts,maxres) -! common /rotat/ - allocate(Ug(2,2,nres)) - allocate(Ugder(2,2,nres)) - allocate(Ug2(2,2,nres)) - allocate(Ug2der(2,2,nres)) -!(2,2,maxres) - allocate(obrot(2,nres)) - allocate(obrot2(2,nres)) - allocate(obrot_der(2,nres)) - allocate(obrot2_der(2,nres)) -!(2,maxres) -! common /precomp1/ - allocate(mu(2,nres)) - allocate(muder(2,nres)) - allocate(Ub2(2,nres)) - Ub2(1,:)=0.0d0 - Ub2(2,:)=0.0d0 - allocate(Ub2der(2,nres)) - allocate(Ctobr(2,nres)) - allocate(Ctobrder(2,nres)) - allocate(Dtobr2(2,nres)) - allocate(Dtobr2der(2,nres)) -!(2,maxres) - allocate(EUg(2,2,nres)) - allocate(EUgder(2,2,nres)) - allocate(CUg(2,2,nres)) - allocate(CUgder(2,2,nres)) - allocate(DUg(2,2,nres)) - allocate(Dugder(2,2,nres)) - allocate(DtUg2(2,2,nres)) - allocate(DtUg2der(2,2,nres)) -!(2,2,maxres) -! common /precomp2/ - allocate(Ug2Db1t(2,nres)) - allocate(Ug2Db1tder(2,nres)) - allocate(CUgb2(2,nres)) - allocate(CUgb2der(2,nres)) -!(2,maxres) - allocate(EUgC(2,2,nres)) - allocate(EUgCder(2,2,nres)) - allocate(EUgD(2,2,nres)) - allocate(EUgDder(2,2,nres)) - allocate(DtUg2EUg(2,2,nres)) - allocate(Ug2DtEUg(2,2,nres)) -!(2,2,maxres) - allocate(Ug2DtEUgder(2,2,2,nres)) - allocate(DtUg2EUgder(2,2,2,nres)) -!(2,2,2,maxres) -! common /rotat_old/ - allocate(costab(nres)) - allocate(sintab(nres)) - allocate(costab2(nres)) - allocate(sintab2(nres)) -!(maxres) -! common /dipmat/ - allocate(a_chuj(2,2,maxconts,nres)) -!(2,2,maxconts,maxres)(maxconts=maxres/4) - allocate(a_chuj_der(2,2,3,5,maxconts,nres)) -!(2,2,3,5,maxconts,maxres)(maxconts=maxres/4) -! common /contdistrib/ - allocate(ncont_sent(nres)) - allocate(ncont_recv(nres)) - - allocate(iat_sent(nres)) -!(maxres) - allocate(iint_sent(4,nres,nres)) - allocate(iint_sent_local(4,nres,nres)) -!(4,maxres,maxres) - allocate(iturn3_sent(4,0:nres+4)) - allocate(iturn4_sent(4,0:nres+4)) - allocate(iturn3_sent_local(4,nres)) - allocate(iturn4_sent_local(4,nres)) -!(4,maxres) - allocate(itask_cont_from(0:nfgtasks-1)) - allocate(itask_cont_to(0:nfgtasks-1)) -!(0:max_fg_procs-1) - - - -!---------------------- -! commom.deriv; -! common /derivat/ - allocate(dcdv(6,maxdim)) - allocate(dxdv(6,maxdim)) -!(6,maxdim) - allocate(dxds(6,nres)) -!(6,maxres) - allocate(gradx(3,nres,0:2)) - allocate(gradc(3,nres,0:2)) -!(3,maxres,2) - allocate(gvdwx(3,nres)) - allocate(gvdwc(3,nres)) - allocate(gelc(3,nres)) - allocate(gelc_long(3,nres)) - allocate(gvdwpp(3,nres)) - allocate(gvdwc_scpp(3,nres)) - allocate(gradx_scp(3,nres)) - allocate(gvdwc_scp(3,nres)) - allocate(ghpbx(3,nres)) - allocate(ghpbc(3,nres)) - allocate(gradcorr(3,nres)) - allocate(gradcorr_long(3,nres)) - allocate(gradcorr5_long(3,nres)) - allocate(gradcorr6_long(3,nres)) - allocate(gcorr6_turn_long(3,nres)) - allocate(gradxorr(3,nres)) - allocate(gradcorr5(3,nres)) - allocate(gradcorr6(3,nres)) -!(3,maxres) - allocate(gloc(0:maxvar,0:2)) - allocate(gloc_x(0:maxvar,2)) -!(maxvar,2) - allocate(gel_loc(3,nres)) - allocate(gel_loc_long(3,nres)) - allocate(gcorr3_turn(3,nres)) - allocate(gcorr4_turn(3,nres)) - allocate(gcorr6_turn(3,nres)) - allocate(gradb(3,nres)) - allocate(gradbx(3,nres)) -!(3,maxres) - allocate(gel_loc_loc(maxvar)) - allocate(gel_loc_turn3(maxvar)) - allocate(gel_loc_turn4(maxvar)) - allocate(gel_loc_turn6(maxvar)) - allocate(gcorr_loc(maxvar)) - allocate(g_corr5_loc(maxvar)) - allocate(g_corr6_loc(maxvar)) -!(maxvar) - allocate(gsccorc(3,nres)) - allocate(gsccorx(3,nres)) -!(3,maxres) - allocate(gsccor_loc(nres)) -!(maxres) - allocate(dtheta(3,2,nres)) -!(3,2,maxres) - allocate(gscloc(3,nres)) - allocate(gsclocx(3,nres)) -!(3,maxres) - allocate(dphi(3,3,nres)) - allocate(dalpha(3,3,nres)) - allocate(domega(3,3,nres)) -!(3,3,maxres) -! common /deriv_scloc/ - allocate(dXX_C1tab(3,nres)) - allocate(dYY_C1tab(3,nres)) - allocate(dZZ_C1tab(3,nres)) - allocate(dXX_Ctab(3,nres)) - allocate(dYY_Ctab(3,nres)) - allocate(dZZ_Ctab(3,nres)) - allocate(dXX_XYZtab(3,nres)) - allocate(dYY_XYZtab(3,nres)) - allocate(dZZ_XYZtab(3,nres)) -!(3,maxres) -! common /mpgrad/ - allocate(jgrad_start(nres)) - allocate(jgrad_end(nres)) -!(maxres) -!---------------------- - -! common /indices/ - allocate(ibond_displ(0:nfgtasks-1)) - allocate(ibond_count(0:nfgtasks-1)) - allocate(ithet_displ(0:nfgtasks-1)) - allocate(ithet_count(0:nfgtasks-1)) - allocate(iphi_displ(0:nfgtasks-1)) - allocate(iphi_count(0:nfgtasks-1)) - allocate(iphi1_displ(0:nfgtasks-1)) - allocate(iphi1_count(0:nfgtasks-1)) - allocate(ivec_displ(0:nfgtasks-1)) - allocate(ivec_count(0:nfgtasks-1)) - allocate(iset_displ(0:nfgtasks-1)) - allocate(iset_count(0:nfgtasks-1)) - allocate(iint_count(0:nfgtasks-1)) - allocate(iint_displ(0:nfgtasks-1)) -!(0:max_fg_procs-1) -!---------------------- -! common.MD -! common /mdgrad/ - allocate(gcart(3,0:nres)) - allocate(gxcart(3,0:nres)) -!(3,0:MAXRES) - allocate(gradcag(3,nres)) - allocate(gradxag(3,nres)) -!(3,MAXRES) -! common /back_constr/ -!el in energy:Econstr_back allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back) - allocate(dutheta(nres)) - allocate(dugamma(nres)) -!(maxres) - allocate(duscdiff(3,nres)) - allocate(duscdiffx(3,nres)) -!(3,maxres) -!el i io:read_fragments -! allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20) -! allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20) -! common /qmeas/ -! allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20) -! allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20) - allocate(mset(0:nprocs)) !(maxprocs/20) - mset(:)=0 -! allocate(ifrag(2,50,nprocs/20)) !(2,50,maxprocs/20) -! allocate(ipair(2,100,nprocs/20)) !(2,100,maxprocs/20) - allocate(dUdconst(3,0:nres)) - allocate(dUdxconst(3,0:nres)) - allocate(dqwol(3,0:nres)) - allocate(dxqwol(3,0:nres)) -!(3,0:MAXRES) -!---------------------- -! common.sbridge -! common /sbridge/ in io_common: read_bridge -!el allocate((:),allocatable :: iss !(maxss) -! common /links/ in io_common: read_bridge -!el real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane -!el integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane -! common /dyn_ssbond/ -! and side-chain vectors in theta or phi. - allocate(dyn_ssbond_ij(0:nres+4,0:nres+4)) -!(maxres,maxres) -! do i=1,nres -! do j=i+1,nres - dyn_ssbond_ij(:,:)=1.0d300 -! enddo -! enddo - - if (nss.gt.0) then - allocate(idssb(nss),jdssb(nss)) -!(maxdim) - endif - allocate(dyn_ss_mask(nres)) -!(maxres) - dyn_ss_mask(:)=.false. -!---------------------- -! common.sccor -! Parameters of the SCCOR term -! common/sccor/ -!el in io_conf: parmread -! allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) -! allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) -! allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) -! allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) -! allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp)) -! allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp) -! allocate(vlor1sccor(maxterm_sccor,20,20)) -! allocate(vlor2sccor(maxterm_sccor,20,20)) -! allocate(vlor3sccor(maxterm_sccor,20,20)) !(maxterm_sccor,20,20) -!---------------- - allocate(gloc_sc(3,0:2*nres,0:10)) -!(3,0:maxres2,10)maxres2=2*maxres - allocate(dcostau(3,3,3,2*nres)) - allocate(dsintau(3,3,3,2*nres)) - allocate(dtauangle(3,3,3,2*nres)) - allocate(dcosomicron(3,3,3,2*nres)) - allocate(domicron(3,3,3,2*nres)) -!(3,3,3,maxres2)maxres2=2*maxres -!---------------------- -! common.var -! common /restr/ - allocate(varall(maxvar)) -!(maxvar)(maxvar=6*maxres) - allocate(mask_theta(nres)) - allocate(mask_phi(nres)) - allocate(mask_side(nres)) -!(maxres) -!---------------------- -! common.vectors -! common /vectors/ - allocate(uy(3,nres)) - allocate(uz(3,nres)) -!(3,maxres) - allocate(uygrad(3,3,2,nres)) - allocate(uzgrad(3,3,2,nres)) -!(3,3,2,maxres) - - return - end subroutine alloc_ener_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module energy diff --git a/source/unres/geometry.F90 b/source/unres/geometry.F90 new file mode 100644 index 0000000..91cfcd4 --- /dev/null +++ b/source/unres/geometry.F90 @@ -0,0 +1,3597 @@ + module geometry +!----------------------------------------------------------------------------- + use io_units + use names + use math + use MPI_data + use geometry_data + use control_data + use energy_data + implicit none +!----------------------------------------------------------------------------- +! commom.bounds +! common /bounds/ +!----------------------------------------------------------------------------- +! commom.chain +! common /chain/ +! common /rotmat/ + real(kind=8),dimension(:,:,:),allocatable :: t,r !(3,3,maxres) +!----------------------------------------------------------------------------- +! common.geo +! common /geo/ +!----------------------------------------------------------------------------- +! common.locmove +! Variables (set in init routine) never modified by local_move +! common /loc_const/ + integer :: init_called + logical :: locmove_output + real(kind=8) :: min_theta, max_theta + real(kind=8) :: dmin2,dmax2 + real(kind=8) :: flag,small,small2 +! Workspace for local_move +! common /loc_work/ + integer :: a_n,b_n,res_n + real(kind=8),dimension(0:7) :: a_ang + real(kind=8),dimension(0:3) :: b_ang + real(kind=8),dimension(0:11) :: res_ang + logical,dimension(0:2,0:7) :: a_tab + logical,dimension(0:2,0:3) :: b_tab + logical,dimension(0:2,0:2,0:11) :: res_tab +!----------------------------------------------------------------------------- +! integer,dimension(:),allocatable :: itype_pdb !(maxres) initialize in molread +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! arcos.f +!----------------------------------------------------------------------------- + real(kind=8) function ARCOS(X) +! implicit real*8 (a-h,o-z) +! include 'COMMON.GEO' +!el local variables + real(kind=8) :: x + IF (DABS(X).LT.1.0D0) GOTO 1 + ARCOS=PIPOL*(1.0d0-DSIGN(1.0D0,X)) + RETURN + 1 ARCOS=DACOS(X) + return + end function ARCOS +!----------------------------------------------------------------------------- +! chainbuild.F +!----------------------------------------------------------------------------- + subroutine chainbuild +! +! Build the virtual polypeptide chain. Side-chain centroids are moveable. +! As of 2/17/95. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' + logical :: lprn +!el local variables + integer :: i,j + real(kind=8) :: be,be1,alfai + integer :: nres2 + nres2=2*nres +! Set lprn=.true. for debugging + lprn = .false. +! +! Define the origin and orientation of the coordinate system and locate the +! first three CA's and SC(2). +! +!elwrite(iout,*)"in chainbuild" + call orig_frame +!elwrite(iout,*)"after orig_frame" +! +! Build the alpha-carbon chain. +! + do i=4,nres + call locate_next_res(i) + enddo +!elwrite(iout,*)"after locate_next_res" +! +! First and last SC must coincide with the corresponding CA. +! + do j=1,3 + dc(j,nres+1)=0.0D0 + dc_norm(j,nres+1)=0.0D0 + dc(j,nres+nres)=0.0D0 + dc_norm(j,nres+nres)=0.0D0 + c(j,nres+1)=c(j,1) + c(j,nres+nres)=c(j,nres) + enddo +! +! Temporary diagnosis +! + if (lprn) then + + call cartprint + write (iout,'(/a)') 'Recalculated internal coordinates' + do i=2,nres-1 + do j=1,3 + c(j,nres2+2)=0.5D0*(c(j,i-1)+c(j,i+1)) !maxres2=2*maxres + enddo + be=0.0D0 + if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) + be1=rad2deg*beta(nres+i,i,nres2+2,i+1) + alfai=0.0D0 + if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) + write (iout,1212) restyp(itype(i)),i,dist(i-1,i),& + alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,nres2+2),be1 + enddo + 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) + + endif + + return + end subroutine chainbuild +!----------------------------------------------------------------------------- + subroutine orig_frame +! +! Define the origin and orientation of the coordinate system and locate +! the first three atoms. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +!el local variables + integer :: i,j + real(kind=8) :: cost,sint + +!el allocate(t(3,3,nres)) !(3,3,maxres) +!el allocate(r(3,3,nres)) !(3,3,maxres) +!el allocate(rt(3,3,nres)) !(3,3,maxres) +!el allocate(dc_norm(3,0:2*nres)) !(3,0:maxres2) +!el allocate(prod(3,3,nres)) !(3,3,maxres) + + cost=dcos(theta(3)) + sint=dsin(theta(3)) + t(1,1,1)=-cost + t(1,2,1)=-sint + t(1,3,1)= 0.0D0 + t(2,1,1)=-sint + t(2,2,1)= cost + t(2,3,1)= 0.0D0 + t(3,1,1)= 0.0D0 + t(3,2,1)= 0.0D0 + t(3,3,1)= 1.0D0 + r(1,1,1)= 1.0D0 + r(1,2,1)= 0.0D0 + r(1,3,1)= 0.0D0 + r(2,1,1)= 0.0D0 + r(2,2,1)= 1.0D0 + r(2,3,1)= 0.0D0 + r(3,1,1)= 0.0D0 + r(3,2,1)= 0.0D0 + r(3,3,1)= 1.0D0 + do i=1,3 + do j=1,3 + rt(i,j,1)=t(i,j,1) + enddo + enddo + do i=1,3 + do j=1,3 + prod(i,j,1)=0.0D0 + prod(i,j,2)=t(i,j,1) + enddo + prod(i,i,1)=1.0D0 + enddo + c(1,1)=0.0D0 + c(2,1)=0.0D0 + c(3,1)=0.0D0 + c(1,2)=vbld(2) + c(2,2)=0.0D0 + c(3,2)=0.0D0 + dc(1,0)=0.0d0 + dc(2,0)=0.0D0 + dc(3,0)=0.0D0 + dc(1,1)=vbld(2) + dc(2,1)=0.0D0 + dc(3,1)=0.0D0 + dc_norm(1,0)=0.0D0 + dc_norm(2,0)=0.0D0 + dc_norm(3,0)=0.0D0 + dc_norm(1,1)=1.0D0 + dc_norm(2,1)=0.0D0 + dc_norm(3,1)=0.0D0 + do j=1,3 + dc_norm(j,2)=prod(j,1,2) + dc(j,2)=vbld(3)*prod(j,1,2) + c(j,3)=c(j,2)+dc(j,2) + enddo + call locate_side_chain(2) + return + end subroutine orig_frame +!----------------------------------------------------------------------------- + subroutine locate_next_res(i) +! +! Locate CA(i) and SC(i-1) +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! +! Define the rotation matrices corresponding to CA(i) +! +!el local variables + integer :: i,j + real(kind=8) :: theti,phii + real(kind=8) :: cost,sint,cosphi,sinphi +#ifdef OSF +#ifdef WHAM_RUN + theti=theta(i) + icrc=0 + call proc_proc(theti,icrc) + if(icrc.eq.1)theti=100.0 + phii=phi(i) + icrc=0 + call proc_proc(phii,icrc) + if(icrc.eq.1)phii=180.0 +#else + theti=theta(i) + if (theti.ne.theti) theti=100.0 + phii=phi(i) + if (phii.ne.phii) phii=180.0 +#endif +#else + theti=theta(i) + phii=phi(i) +#endif + cost=dcos(theti) + sint=dsin(theti) + cosphi=dcos(phii) + sinphi=dsin(phii) +! Define the matrices of the rotation about the virtual-bond valence angles +! theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this +! program), R(i,j,k), and, the cumulative matrices of rotation RT + t(1,1,i-2)=-cost + t(1,2,i-2)=-sint + t(1,3,i-2)= 0.0D0 + t(2,1,i-2)=-sint + t(2,2,i-2)= cost + t(2,3,i-2)= 0.0D0 + t(3,1,i-2)= 0.0D0 + t(3,2,i-2)= 0.0D0 + t(3,3,i-2)= 1.0D0 + r(1,1,i-2)= 1.0D0 + r(1,2,i-2)= 0.0D0 + r(1,3,i-2)= 0.0D0 + r(2,1,i-2)= 0.0D0 + r(2,2,i-2)=-cosphi + r(2,3,i-2)= sinphi + r(3,1,i-2)= 0.0D0 + r(3,2,i-2)= sinphi + r(3,3,i-2)= cosphi + rt(1,1,i-2)=-cost + rt(1,2,i-2)=-sint + rt(1,3,i-2)=0.0D0 + rt(2,1,i-2)=sint*cosphi + rt(2,2,i-2)=-cost*cosphi + rt(2,3,i-2)=sinphi + rt(3,1,i-2)=-sint*sinphi + rt(3,2,i-2)=cost*sinphi + rt(3,3,i-2)=cosphi + call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) + do j=1,3 + dc_norm(j,i-1)=prod(j,1,i-1) + dc(j,i-1)=vbld(i)*prod(j,1,i-1) + c(j,i)=c(j,i-1)+dc(j,i-1) + enddo +!d print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) +! +! Now calculate the coordinates of SC(i-1) +! + call locate_side_chain(i-1) + return + end subroutine locate_next_res +!----------------------------------------------------------------------------- + subroutine locate_side_chain(i) +! +! Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' + integer :: i,j,k + real(kind=8),dimension(3) :: xx + real(kind=8) :: alphi,omegi,theta2 + real(kind=8) :: dsci,dsci_inv,sinalphi,cosalphi,cosomegi,sinomegi + real(kind=8) :: xp,yp,zp,cost2,sint2,rj +! dsci=dsc(itype(i)) +! dsci_inv=dsc_inv(itype(i)) + dsci=vbld(i+nres) + dsci_inv=vbld_inv(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) +#ifdef WHAM_RUN +! detecting NaNQ + icrc=0 + call proc_proc(alphi,icrc) + if(icrc.eq.1)alphi=100.0 + icrc=0 + call proc_proc(omegi,icrc) + if(icrc.eq.1)omegi=-100.0 +#else + if (alphi.ne.alphi) alphi=100.0 + if (omegi.ne.omegi) omegi=-100.0 +#endif +#else + alphi=alph(i) + omegi=omeg(i) +#endif + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + xp= dsci*cosalphi + yp= dsci*sinalphi*cosomegi + zp=-dsci*sinalphi*sinomegi +! Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its +! X-axis aligned with the vector DC(*,i) + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + xx(1)= xp*cost2+yp*sint2 + xx(2)=-xp*sint2+yp*cost2 + xx(3)= zp +!d print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, +!d & xp,yp,zp,(xx(k),k=1,3) + do j=1,3 + xloc(j,i)=xx(j) + enddo +! Bring the SC vectors to the common coordinate system. + xx(1)=xloc(1,i) + xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) + xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) + do j=1,3 + xrot(j,i)=xx(j) + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i-1)*xx(k) + enddo + dc(j,nres+i)=rj + dc_norm(j,nres+i)=rj*dsci_inv + c(j,nres+i)=c(j,i)+rj + enddo + return + end subroutine locate_side_chain +!----------------------------------------------------------------------------- +! checkder_p.F +!----------------------------------------------------------------------------- + subroutine int_from_cart1(lprn) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer :: ierror +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' +! include 'COMMON.LOCAL' +! include 'COMMON.NAMES' +! include 'COMMON.SETUP' +! include 'COMMON.TIME1' + logical :: lprn +!el local variables + integer :: i,j + real(kind=8) :: dnorm1,dnorm2,be + integer :: nres2 + nres2=2*nres + if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' +#ifdef TIMING + time01=MPI_Wtime() +#endif + +#ifdef WHAM_RUN + vbld(nres+1)=0.0d0 +!write(iout,*)"geometry warring, vbld=",(vbld(i),i=1,nres+1) + vbld(2*nres)=0.0d0 + vbld_inv(nres+1)=0.0d0 + vbld_inv(2*nres)=0.0d0 +#endif + +#if defined(PARINT) && defined(MPI) + do i=iint_start,iint_end +#else + do i=2,nres +#endif + dnorm1=dist(i-1,i) + dnorm2=dist(i,i+1) + do j=1,3 + c(j,nres2+2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 & + +(c(j,i+1)-c(j,i))/dnorm2) + enddo + be=0.0D0 + if (i.gt.2) then + if (i.le.nres) phi(i+1)=beta(i-2,i-1,i,i+1) + if ((itype(i).ne.10).and.(itype(i-1).ne.10)) then + tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) + endif + if (itype(i-1).ne.10) then + tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) + omicron(1,i)=alpha(i-2,i-1,i-1+nres) + omicron(2,i)=alpha(i-1+nres,i-1,i) + endif + if (itype(i).ne.10) then + tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) + endif + endif + omeg(i)=beta(nres+i,i,nres2+2,i+1) + alph(i)=alpha(nres+i,i,nres2+2) + theta(i+1)=alpha(i-1,i,i+1) + vbld(i)=dist(i-1,i) + vbld_inv(i)=1.0d0/vbld(i) + vbld(nres+i)=dist(nres+i,i) + if (itype(i).ne.10) then + vbld_inv(nres+i)=1.0d0/vbld(nres+i) + else + vbld_inv(nres+i)=0.0d0 + endif + enddo +#if defined(PARINT) && defined(MPI) + if (nfgtasks1.gt.1) then +!d write(iout,*) "iint_start",iint_start," iint_count", +!d & (iint_count(i),i=0,nfgtasks-1)," iint_displ", +!d & (iint_displ(i),i=0,nfgtasks-1) +!d write (iout,*) "Gather vbld backbone" +!d call flush(iout) + time00=MPI_Wtime() + call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +!d write (iout,*) "Gather vbld_inv" +!d call flush(iout) + call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +!d write (iout,*) "Gather vbld side chain" +!d call flush(iout) + call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +!d write (iout,*) "Gather vbld_inv side chain" +!d call flush(iout) + call MPI_Allgatherv(vbld_inv(iint_start+nres),& + iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1),& + iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +!d write (iout,*) "Gather theta" +!d call flush(iout) + call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +!d write (iout,*) "Gather phi" +!d call flush(iout) + call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#ifdef CRYST_SC +!d write (iout,*) "Gather alph" +!d call flush(iout) + call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +!d write (iout,*) "Gather omeg" +!d call flush(iout) + call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1),& + MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0),& + MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#endif + time_gather=time_gather+MPI_Wtime()-time00 + endif +#endif + do i=1,nres-1 + do j=1,3 +!#ifdef WHAM_RUN +#if defined(WHAM_RUN) || defined(CLUSTER) + dc(j,i)=c(j,i+1)-c(j,i) +#endif + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 +!#ifdef WHAM_RUN +#if defined(WHAM_RUN) || defined(CLUSTER) + dc(j,i+nres)=c(j,i+nres)-c(j,i) +#endif + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + enddo + if (lprn) then + do i=2,nres + write (iout,1212) restyp(itype(i)),i,vbld(i),& + rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),& + rad2deg*alph(i),rad2deg*omeg(i) + enddo + endif + 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) +#ifdef TIMING + time_intfcart=time_intfcart+MPI_Wtime()-time01 +#endif + return + end subroutine int_from_cart1 +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- +! check_sc_distr.f +!----------------------------------------------------------------------------- + subroutine check_sc_distr +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.TIME1' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' + logical :: fail + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + real(kind=8) :: hrtime,mintime,sectime + integer,parameter :: MaxSample=10000000 + real(kind=8),parameter :: delt=1.0D0/MaxSample + real(kind=8),dimension(0:72,0:90) :: prob +!el local variables + integer :: it,i,j,isample,indal,indom + real(kind=8) :: al,om,dV + dV=2.0D0*5.0D0*deg2rad*deg2rad + print *,'dv=',dv + do 10 it=1,1 + if (it.eq.10) goto 10 + open (20,file=restyp(it)//'_distr.sdc',status='unknown') + call gen_side(it,90.0D0 * deg2rad,al,om,fail) + close (20) + goto 10 + open (20,file=restyp(it)//'_distr1.sdc',status='unknown') + do i=0,90 + do j=0,72 + prob(j,i)=0.0D0 + enddo + enddo + do isample=1,MaxSample + call gen_side(it,90.0D0 * deg2rad,al,om,fail) + indal=rad2deg*al/2 + indom=(rad2deg*om+180.0D0)/5 + prob(indom,indal)=prob(indom,indal)+delt + enddo + do i=45,90 + do j=0,72 + write (20,'(2f10.3,1pd15.5)') 2*i+0.0D0,5*j-180.0D0,& + prob(j,i)/dV + enddo + enddo + 10 continue + return + end subroutine check_sc_distr +#endif +!----------------------------------------------------------------------------- +! convert.f +!----------------------------------------------------------------------------- + subroutine geom_to_var(n,x) +! +! Transfer the geometry parameters to the variable array. +! The positions of variables are as follows: +! 1. Virtual-bond torsional angles: 1 thru nres-3 +! 2. Virtual-bond valence angles: nres-2 thru 2*nres-5 +! 3. The polar angles alpha of local SC orientation: 2*nres-4 thru +! 2*nres-4+nside +! 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 +! thru 2*nre-4+2*nside +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' + integer :: n,i + real(kind=8),dimension(n) :: x +!d print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar + do i=4,nres + x(i-3)=phi(i) +!d print *,i,i-3,phi(i) + enddo + if (n.eq.nphi) return + do i=3,nres + x(i-2+nphi)=theta(i) +!d print *,i,i-2+nphi,theta(i) + enddo + if (n.eq.nphi+ntheta) return + do i=2,nres-1 + if (ialph(i,1).gt.0) then + x(ialph(i,1))=alph(i) + x(ialph(i,1)+nside)=omeg(i) +!d print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i) + endif + enddo + return + end subroutine geom_to_var +!----------------------------------------------------------------------------- + subroutine var_to_geom(n,x) +! +! Update geometry parameters according to the variable array. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.IOUNITS' + integer :: n,i,ii + real(kind=8),dimension(n) :: x + logical :: change !,reduce +!el alph=0.0d0 +!el omeg=0.0d0 +!el phi=0.0d0 +!el theta=0.0d0 + + change=reduce(x) + if (n.gt.nphi+ntheta) then + do i=1,nside + ii=ialph(i,2) + alph(ii)=x(nphi+ntheta+i) + omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) +!elwrite(iout,*) "alph",ii,alph +!elwrite(iout,*) "omeg",ii,omeg + enddo + endif + do i=4,nres + phi(i)=x(i-3) +!elwrite(iout,*) "phi",i,phi + enddo + if (n.eq.nphi) return + do i=3,nres + theta(i)=x(i-2+nphi) +!elwrite(iout,*) "theta",i,theta + if (theta(i).eq.pi) theta(i)=0.99d0*pi + x(i-2+nphi)=theta(i) + enddo + return + end subroutine var_to_geom +!----------------------------------------------------------------------------- + logical function convert_side(alphi,omegi) +! implicit none + real(kind=8) :: alphi,omegi +!el real(kind=8) :: pinorm +! include 'COMMON.GEO' + convert_side=.false. +! Apply periodicity restrictions. + if (alphi.gt.pi) then + alphi=dwapi-alphi + omegi=pinorm(omegi+pi) + convert_side=.true. + endif + return + end function convert_side +!----------------------------------------------------------------------------- + logical function reduce(x) +! +! Apply periodic restrictions to variables. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + logical :: zm,zmiana !,convert_side + real(kind=8),dimension(nvar) :: x + integer :: i,ii,iii + zmiana=.false. + do i=4,nres + x(i-3)=pinorm(x(i-3)) + enddo + if (nvar.gt.nphi+ntheta) then + do i=1,nside + ii=nphi+ntheta+i + iii=ii+nside + x(ii)=thetnorm(x(ii)) + x(iii)=pinorm(x(iii)) +! Apply periodic restrictions. + zm=convert_side(x(ii),x(iii)) + zmiana=zmiana.or.zm + enddo + endif + if (nvar.eq.nphi) return + do i=3,nres + ii=i-2+nphi + iii=i-3 + x(ii)=dmod(x(ii),dwapi) +! Apply periodic restrictions. + if (x(ii).gt.pi) then + zmiana=.true. + x(ii)=dwapi-x(ii) + if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) + if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) + ii=ialph(i-1,1) + if (ii.gt.0) then + x(ii)=dmod(pi-x(ii),dwapi) + x(ii+nside)=pinorm(-x(ii+nside)) + zm=convert_side(x(ii),x(ii+nside)) + endif + else if (x(ii).lt.-pi) then + zmiana=.true. + x(ii)=dwapi+x(ii) + ii=ialph(i-1,1) + if (ii.gt.0) then + x(ii)=dmod(pi-x(ii),dwapi) + x(ii+nside)=pinorm(-pi-x(ii+nside)) + zm=convert_side(x(ii),x(ii+nside)) + endif + else if (x(ii).lt.0.0d0) then + zmiana=.true. + x(ii)=-x(ii) + if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) + if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) + ii=ialph(i-1,1) + if (ii.gt.0) then + x(ii+nside)=pinorm(-x(ii+nside)) + zm=convert_side(x(ii),x(ii+nside)) + endif + endif + enddo + reduce=zmiana + return + end function reduce +!----------------------------------------------------------------------------- + real(kind=8) function thetnorm(x) +! This function puts x within [0,2Pi]. + implicit none + real(kind=8) :: x,xx +! include 'COMMON.GEO' + xx=dmod(x,dwapi) + if (xx.lt.0.0d0) xx=xx+dwapi + if (xx.gt.0.9999d0*pi) xx=0.9999d0*pi + thetnorm=xx + return + end function thetnorm +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- + subroutine var_to_geom_restr(n,xx) +! +! Update geometry parameters according to the variable array. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.IOUNITS' + integer :: n,i,ii + real(kind=8),dimension(6*nres) :: x,xx !(maxvar) (maxvar=6*maxres) + logical :: change !,reduce + + call xx2x(x,xx) + change=reduce(x) + do i=1,nside + ii=ialph(i,2) + alph(ii)=x(nphi+ntheta+i) + omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) + enddo + do i=4,nres + phi(i)=x(i-3) + enddo + do i=3,nres + theta(i)=x(i-2+nphi) + if (theta(i).eq.pi) theta(i)=0.99d0*pi + x(i-2+nphi)=theta(i) + enddo + return + end subroutine var_to_geom_restr +!----------------------------------------------------------------------------- +! gen_rand_conf.F +!----------------------------------------------------------------------------- + subroutine gen_rand_conf(nstart,*) +! Generate random conformation or chain cut and regrowth. + use mcm_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.MCM' +! include 'COMMON.GEO' +! include 'COMMON.CONTROL' + logical :: back,fail !overlap, +!el local variables + integer :: i,nstart,maxsi,nsi,maxnit,nit,niter + integer :: it1,it2,it,j +!d print *,' CG Processor',me,' maxgen=',maxgen + maxsi=100 +!d write (iout,*) 'Gen_Rand_conf: nstart=',nstart + if (nstart.lt.5) then + it1=iabs(itype(2)) + phi(4)=gen_phi(4,iabs(itype(2)),iabs(itype(3))) +! write(iout,*)'phi(4)=',rad2deg*phi(4) + if (nstart.lt.3) theta(3)=gen_theta(iabs(itype(2)),pi,phi(4)) +! write(iout,*)'theta(3)=',rad2deg*theta(3) + if (it1.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(it1,theta(3),alph(2),omeg(2),fail) + nsi=nsi+1 + enddo + if (nsi.gt.maxsi) return 1 + endif ! it1.ne.10 + call orig_frame + i=4 + nstart=4 + else + i=nstart + nstart=max0(i,4) + endif + + maxnit=0 + + nit=0 + niter=0 + back=.false. + do while (i.le.nres .and. niter.lt.maxgen) + if (i.lt.nstart) then + if(iprint.gt.1) then + write (iout,'(/80(1h*)/2a/80(1h*))') & + 'Generation procedure went down to ',& + 'chain beginning. Cannot continue...' + write (*,'(/80(1h*)/2a/80(1h*))') & + 'Generation procedure went down to ',& + 'chain beginning. Cannot continue...' + endif + return 1 + endif + it1=iabs(itype(i-1)) + it2=iabs(itype(i-2)) + it=iabs(itype(i)) +! print *,'Gen_Rand_Conf: i=',i,' it=',it,' it1=',it1,' it2=',it2, +! & ' nit=',nit,' niter=',niter,' maxgen=',maxgen + phi(i+1)=gen_phi(i+1,it1,it) + if (back) then + phi(i)=gen_phi(i+1,it2,it1) +! print *,'phi(',i,')=',phi(i) + theta(i-1)=gen_theta(it2,phi(i-1),phi(i)) + if (it2.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail) + nsi=nsi+1 + enddo + if (nsi.gt.maxsi) return 1 + endif + call locate_next_res(i-1) + endif + theta(i)=gen_theta(it1,phi(i),phi(i+1)) + if (it1.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail) + nsi=nsi+1 + enddo + if (nsi.gt.maxsi) return 1 + endif + call locate_next_res(i) + if (overlap(i-1)) then + if (nit.lt.maxnit) then + back=.true. + nit=nit+1 + else + nit=0 + if (i.gt.3) then + back=.true. + i=i-1 + else + write (iout,'(a)') & + 'Cannot generate non-overlaping conformation. Increase MAXNIT.' + write (*,'(a)') & + 'Cannot generate non-overlaping conformation. Increase MAXNIT.' + return 1 + endif + endif + else + back=.false. + nit=0 + i=i+1 + endif + niter=niter+1 + enddo + if (niter.ge.maxgen) then + write (iout,'(a,2i5)') & + 'Too many trials in conformation generation',niter,maxgen + write (*,'(a,2i5)') & + 'Too many trials in conformation generation',niter,maxgen + return 1 + endif + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,nres+nres)=c(j,nres) + enddo + return + end subroutine gen_rand_conf +!----------------------------------------------------------------------------- + logical function overlap(i) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' + integer :: i,j,iti,itj,iteli,itelj,k + real(kind=8) :: redfac,rcomp + integer :: nres2 + nres2=2*nres + data redfac /0.5D0/ + overlap=.false. + iti=iabs(itype(i)) + if (iti.gt.ntyp) return +! Check for SC-SC overlaps. +!d print *,'nnt=',nnt,' nct=',nct + do j=nnt,i-1 + itj=iabs(itype(j)) + if (j.lt.i-1 .or. ipot.ne.4) then + rcomp=sigmaii(iti,itj) + else + rcomp=sigma(iti,itj) + endif +!d print *,'j=',j + if (dist(nres+i,nres+j).lt.redfac*rcomp) then + overlap=.true. +! print *,'overlap, SC-SC: i=',i,' j=',j, +! & ' dist=',dist(nres+i,nres+j),' rcomp=', +! & rcomp + return + endif + enddo +! Check for overlaps between the added peptide group and the preceding +! SCs. + iteli=itel(i) + do j=1,3 +! c(j,nres2+1)=0.5D0*(c(j,i)+c(j,i+1)) + c(j,nres2+3)=0.5D0*(c(j,i)+c(j,i+1)) + enddo + do j=nnt,i-2 + itj=iabs(itype(j)) +!d print *,'overlap, p-Sc: i=',i,' j=',j, +!d & ' dist=',dist(nres+j,maxres2+1) + if (dist(nres+j,nres2+3).lt.4.0D0*redfac) then + overlap=.true. + return + endif + enddo +! Check for overlaps between the added side chain and the preceding peptide +! groups. + do j=1,nnt-2 + do k=1,3 + c(k,nres2+3)=0.5D0*(c(k,j)+c(k,j+1)) + enddo +!d print *,'overlap, SC-p: i=',i,' j=',j, +!d & ' dist=',dist(nres+i,maxres2+1) + if (dist(nres+i,nres2+3).lt.4.0D0*redfac) then + overlap=.true. + return + endif + enddo +! Check for p-p overlaps + do j=1,3 + c(j,nres2+4)=0.5D0*(c(j,i)+c(j,i+1)) + enddo + do j=nnt,i-2 + itelj=itel(j) + do k=1,3 + c(k,nres2+4)=0.5D0*(c(k,j)+c(k,j+1)) + enddo +!d print *,'overlap, p-p: i=',i,' j=',j, +!d & ' dist=',dist(maxres2+1,maxres2+2) + if(iteli.ne.0.and.itelj.ne.0)then + if (dist(nres2+3,nres2+4).lt.rpp(iteli,itelj)*redfac) then + overlap=.true. + return + endif + endif + enddo + return + end function overlap +!----------------------------------------------------------------------------- + real(kind=8) function gen_phi(i,it1,it2) + use random, only:ran_number +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.BOUNDS' + integer :: i,it1,it2 +! gen_phi=ran_number(-pi,pi) +! 8/13/98 Generate phi using pre-defined boundaries + gen_phi=ran_number(phibound(1,i),phibound(2,i)) + return + end function gen_phi +!----------------------------------------------------------------------------- + real(kind=8) function gen_theta(it,gama,gama1) + use random,only:binorm +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.GEO' + real(kind=8),dimension(2) :: y,z + real(kind=8) :: theta_max,theta_min,sig,ak +!el local variables + integer :: j,it,k + real(kind=8) :: gama,gama1,thet_pred_mean,theta_temp +! print *,'gen_theta: it=',it + theta_min=0.05D0*pi + theta_max=0.95D0*pi + if (dabs(gama).gt.dwapi) then + y(1)=dcos(gama) + y(2)=dsin(gama) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (dabs(gama1).gt.dwapi) then + z(1)=dcos(gama1) + z(2)=dsin(gama1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif + thet_pred_mean=a0thet(it) + do k=1,2 + thet_pred_mean=thet_pred_mean+athet(k,it,1,1)*y(k) & + +bthet(k,it,1,1)*z(k) + enddo + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo + sig=0.5D0/(sig*sig+sigc0(it)) + ak=dexp(gthet(1,it)- & + 0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2) +! print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3) +! print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak + theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak) + if (theta_temp.lt.theta_min) theta_temp=theta_min + if (theta_temp.gt.theta_max) theta_temp=theta_max + gen_theta=theta_temp +! print '(a)','Exiting GENTHETA.' + return + end function gen_theta +!----------------------------------------------------------------------------- + subroutine gen_side(it,the,al,om,fail) + use random, only:ran_number,mult_norm1 +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' + real(kind=8) :: MaxBoxLen=10.0D0 + real(kind=8),dimension(3,3) :: Ap_inv,a,vec + real(kind=8),dimension(:,:),allocatable :: z !(3,maxlob) + real(kind=8),dimension(:),allocatable :: W1,detAp !(maxlob) + real(kind=8),dimension(:),allocatable :: sumW !(0:maxlob) + real(kind=8),dimension(2) :: y,cm,eig + real(kind=8),dimension(2,2) :: box + real(kind=8),dimension(100) :: work + real(kind=8) :: eig_limit=1.0D-8 + real(kind=8) :: Big=10.0D0 + logical :: lprint,fail,lcheck +!el local variables + integer :: it,i,j,k,l,nlobit,ial,iom,iii,ilob + real(kind=8) :: the,al,om,detApi,wart,y2,wykl,radmax + real(kind=8) :: tant,zz1,W1i,radius,zk,fac,dV,sum,sum1 + real(kind=8) :: which_lobe + lcheck=.false. + lprint=.false. + fail=.false. + if (the.eq.0.0D0 .or. the.eq.pi) then +#ifdef MPI + write (*,'(a,i4,a,i3,a,1pe14.5)') & + 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the +#else +!d write (iout,'(a,i3,a,1pe14.5)') +!d & 'Error in GenSide: it=',it,' theta=',the +#endif + fail=.true. + return + endif + tant=dtan(the-pipol) + nlobit=nlob(it) + allocate(z(3,nlobit)) + allocate(W1(nlobit)) + allocate(detAp(nlobit)) + allocate(sumW(0:nlobit)) + if (lprint) then +#ifdef MPI + print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.' + write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.' +#endif + print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant + write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the,& + ' tant=',tant + endif + do i=1,nlobit + zz1=tant-censc(1,i,it) + do k=1,3 + do l=1,3 + a(k,l)=gaussc(k,l,i,it) + enddo + enddo + detApi=a(2,2)*a(3,3)-a(2,3)**2 + Ap_inv(2,2)=a(3,3)/detApi + Ap_inv(2,3)=-a(2,3)/detApi + Ap_inv(3,2)=Ap_inv(2,3) + Ap_inv(3,3)=a(2,2)/detApi + if (lprint) then + write (*,'(/a,i2/)') 'Cluster #',i + write (*,'(3(1pe14.5),5x,1pe14.5)') & + ((a(l,k),l=1,3),censc(k,i,it),k=1,3) + write (iout,'(/a,i2/)') 'Cluster #',i + write (iout,'(3(1pe14.5),5x,1pe14.5)') & + ((a(l,k),l=1,3),censc(k,i,it),k=1,3) + endif + W1i=0.0D0 + do k=2,3 + do l=2,3 + W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l) + enddo + enddo + W1i=a(1,1)-W1i + W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1) +! if (lprint) write(*,'(a,3(1pe15.5)/)') +! & 'detAp, W1, anormi',detApi,W1i,anormi + do k=2,3 + zk=censc(k,i,it) + do l=2,3 + zk=zk+zz1*Ap_inv(k,l)*a(l,1) + enddo + z(k,i)=zk + enddo + detAp(i)=dsqrt(detApi) + enddo + + if (lprint) then + print *,'W1:',(w1(i),i=1,nlobit) + print *,'detAp:',(detAp(i),i=1,nlobit) + print *,'Z' + do i=1,nlobit + print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3) + enddo + write (iout,*) 'W1:',(w1(i),i=1,nlobit) + write (iout,*) 'detAp:',(detAp(i),i=1,nlobit) + write (iout,*) 'Z' + do i=1,nlobit + write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3) + enddo + endif + if (lcheck) then +! Writing the distribution just to check the procedure + fac=0.0D0 + dV=deg2rad**2*10.0D0 + sum=0.0D0 + sum1=0.0D0 + do i=1,nlobit + fac=fac+W1(i)/detAp(i) + enddo + fac=1.0D0/(2.0D0*fac*pi) +!d print *,it,'fac=',fac + do ial=90,180,2 + y(1)=deg2rad*ial + do iom=-180,180,5 + y(2)=deg2rad*iom + wart=0.0D0 + do i=1,nlobit + do j=2,3 + do k=2,3 + a(j-1,k-1)=gaussc(j,k,i,it) + enddo + enddo + y2=y(2) + + do iii=-1,1 + + y(2)=y2+iii*dwapi + + wykl=0.0D0 + do j=1,2 + do k=1,2 + wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i)) + enddo + enddo + wart=wart+W1(i)*dexp(-0.5D0*wykl) + + enddo + + y(2)=y2 + + enddo +! print *,'y',y(1),y(2),' fac=',fac + wart=fac*wart + write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart + sum=sum+wart + sum1=sum1+1.0D0 + enddo + enddo +! print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV + return + endif + +! Calculate the CM of the system +! + do i=1,nlobit + W1(i)=W1(i)/detAp(i) + enddo + sumW(0)=0.0D0 + do i=1,nlobit + sumW(i)=sumW(i-1)+W1(i) + enddo + cm(1)=z(2,1)*W1(1) + cm(2)=z(3,1)*W1(1) + do j=2,nlobit + cm(1)=cm(1)+z(2,j)*W1(j) + cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1))) + enddo + cm(1)=cm(1)/sumW(nlobit) + cm(2)=cm(2)/sumW(nlobit) + if (cm(1).gt.Big .or. cm(1).lt.-Big .or. & + cm(2).gt.Big .or. cm(2).lt.-Big) then +!d write (iout,'(a)') +!d & 'Unexpected error in GenSide - CM coordinates too large.' +!d write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2) +!d write (*,'(a)') +!d & 'Unexpected error in GenSide - CM coordinates too large.' +!d write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2) + fail=.true. + return + endif +!d print *,'CM:',cm(1),cm(2) +! +! Find the largest search distance from CM +! + radmax=0.0D0 + do i=1,nlobit + do j=2,3 + do k=2,3 + a(j-1,k-1)=gaussc(j,k,i,it) + enddo + enddo +#ifdef NAG + call f02faf('N','U',2,a,3,eig,work,100,ifail) +#else + call djacob(2,3,10000,1.0d-10,a,vec,eig) +#endif +#ifdef MPI + if (lprint) then + print *,'*************** CG Processor',me + print *,'CM:',cm(1),cm(2) + write (iout,*) '*************** CG Processor',me + write (iout,*) 'CM:',cm(1),cm(2) + print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) + write (iout,'(A,8f10.5)') & + 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) + endif +#endif + if (eig(1).lt.eig_limit) then + write(iout,'(a)') & + 'From Mult_Norm: Eigenvalues of A are too small.' + write(*,'(a)') & + 'From Mult_Norm: Eigenvalues of A are too small.' + fail=.true. + return + endif + radius=0.0D0 +!d print *,'i=',i + do j=1,2 + radius=radius+pinorm(z(j+1,i)-cm(j))**2 + enddo + radius=dsqrt(radius)+3.0D0/dsqrt(eig(1)) + if (radius.gt.radmax) radmax=radius + enddo + if (radmax.gt.pi) radmax=pi +! +! Determine the boundaries of the search rectangle. +! + if (lprint) then + print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) ) + print '(a,4(1pe14.4))','radmax: ',radmax + endif + box(1,1)=dmax1(cm(1)-radmax,0.0D0) + box(2,1)=dmin1(cm(1)+radmax,pi) + box(1,2)=cm(2)-radmax + box(2,2)=cm(2)+radmax + if (lprint) then +#ifdef MPI + print *,'CG Processor',me,' Array BOX:' +#else + print *,'Array BOX:' +#endif + print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2) + print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) ) +#ifdef MPI + write (iout,*)'CG Processor',me,' Array BOX:' +#else + write (iout,*)'Array BOX:' +#endif + write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2) + write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) ) + endif + if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then +#ifdef MPI + write (iout,'(a,i4,a,3e15.5)') 'CG Processor:',me,': bad sampling box.',box(1,2),box(2,2),radmax + write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' +#else +! write (iout,'(a)') 'Bad sampling box.' +#endif + fail=.true. + return + endif + which_lobe=ran_number(0.0D0,sumW(nlobit)) +! print '(a,1pe14.4)','which_lobe=',which_lobe + do i=1,nlobit + if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1 + enddo + 1 ilob=i +! print *,'ilob=',ilob,' nlob=',nlob(it) + do i=2,3 + cm(i-1)=z(i,ilob) + do j=2,3 + a(i-1,j-1)=gaussc(i,j,ilob,it) + enddo + enddo +!d print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.' + call mult_norm1(3,2,a,cm,box,y,fail) + if (fail) return + al=y(1) + om=pinorm(y(2)) +!d print *,'al=',al,' om=',om +!d stop + return + end subroutine gen_side +!----------------------------------------------------------------------------- + subroutine overlap_sc(scfail) +! +! Internal and cartesian coordinates must be consistent as input, +! and will be up-to-date on return. +! At the end of this procedure, scfail is true if there are +! overlapping residues left, or false otherwise (success) +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.VAR' +! include 'COMMON.SBRIDGE' +! include 'COMMON.IOUNITS' + logical :: had_overlaps,fail,scfail + integer,dimension(nres) :: ioverlap !(maxres) + integer :: ioverlap_last,k,maxsi,i,iti,nsi + integer :: ires,j + + had_overlaps=.false. + call overlap_sc_list(ioverlap,ioverlap_last) + if (ioverlap_last.gt.0) then + write (iout,*) '#OVERLAPing residues ',ioverlap_last + write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last) + had_overlaps=.true. + endif + + maxsi=1000 + do k=1,1000 + if (ioverlap_last.eq.0) exit + + do ires=1,ioverlap_last + i=ioverlap(ires) + iti=iabs(itype(i)) + if (iti.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) + nsi=nsi+1 + enddo + if(fail) goto 999 + endif + enddo + + call chainbuild + call overlap_sc_list(ioverlap,ioverlap_last) +! write (iout,*) 'Overlaping residues ',ioverlap_last, +! & (ioverlap(j),j=1,ioverlap_last) + enddo + + if (k.le.1000.and.ioverlap_last.eq.0) then + scfail=.false. + if (had_overlaps) then + write (iout,*) '#OVERLAPing all corrected after ',k,& + ' random generation' + endif + else + scfail=.true. + write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last + write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last) + endif + + return + + 999 continue + write (iout,'(a30,i5,a12,i4)') & + '#OVERLAP FAIL in gen_side after',maxsi,& + 'iter for RES',i + scfail=.true. + return + end subroutine overlap_sc +!----------------------------------------------------------------------------- + subroutine overlap_sc_list(ioverlap,ioverlap_last) + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.VAR' +! include 'COMMON.CALC' + logical :: fail + integer,dimension(nres) :: ioverlap !(maxres) + integer :: ioverlap_last +!el local variables + integer :: ind,iint + real(kind=8) :: redfac,sig !rrij,sigsq, + integer :: itypi,itypj,itypi1 + real(kind=8) :: xi,yi,zi,sig0ij,rcomp,rrij,rij_shift + data redfac /0.5D0/ + + ioverlap_last=0 +! Check for SC-SC overlaps and mark residues +! print *,'>>overlap_sc nnt=',nnt,' nct=',nct + ind=0 + do i=iatsc_s,iatsc_e + itypi=iabs(itype(i)) + itypi1=iabs(itype(i+1)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=dsc_inv(itypi) +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=iabs(itype(j)) + dscj_inv=dsc_inv(itypj) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + if (j.gt.i+1) then + rcomp=sigmaii(itypi,itypj) + else + rcomp=sigma(itypi,itypj) + endif +! print '(2(a3,2i3),a3,2f10.5)', +! & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j) +! & ,rcomp + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij + +!t if ( 1.0/rij .lt. redfac*rcomp .or. +!t & rij_shift.le.0.0D0 ) then + if ( rij_shift.le.0.0D0 ) then +!d write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') +!d & 'overlap SC-SC: i=',i,' j=',j, +!d & ' dist=',dist(nres+i,nres+j),' rcomp=', +!d & rcomp,1.0/rij,rij_shift + ioverlap_last=ioverlap_last+1 + ioverlap(ioverlap_last)=i + do k=1,ioverlap_last-1 + if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1 + enddo + ioverlap_last=ioverlap_last+1 + ioverlap(ioverlap_last)=j + do k=1,ioverlap_last-1 + if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1 + enddo + endif + enddo + enddo + enddo + return + end subroutine overlap_sc_list +#endif +!----------------------------------------------------------------------------- +! energy_p_new_barrier.F +!----------------------------------------------------------------------------- + subroutine sc_angular +! Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, +! om12. Called by ebp, egb, and egbv. + use calc_data +! implicit none +! include 'COMMON.CALC' +! include 'COMMON.IOUNITS' + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + chiom12=chi12*om12 +! Calculate eps1(om12) and its derivative in om12 + faceps1=1.0D0-om12*chiom12 + faceps1_inv=1.0D0/faceps1 + eps1=dsqrt(faceps1_inv) +! Following variable is eps1*deps1/dom12 + eps1_om12=faceps1_inv*chiom12 +! diagnostics only +! faceps1_inv=om12 +! eps1=om12 +! eps1_om12=1.0d0 +! write (iout,*) "om12",om12," eps1",eps1 +! Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, +! and om12. + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 + sigsq=1.0D0-facsig*faceps1_inv + sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv + sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv + sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 +! diagnostics only +! sigsq=1.0d0 +! sigsq_om1=0.0d0 +! sigsq_om2=0.0d0 +! sigsq_om12=0.0d0 +! write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 +! write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, +! & " eps1",eps1 +! Calculate eps2 and its derivatives in om1, om2, and om12. + chipom1=chip1*om1 + chipom2=chip2*om2 + chipom12=chip12*om12 + facp=1.0D0-om12*chipom12 + facp_inv=1.0D0/facp + facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 +! write (iout,*) "chipom1",chipom1," chipom2",chipom2, +! & " chipom12",chipom12," facp",facp," facp_inv",facp_inv +! Following variable is the square root of eps2 + eps2rt=1.0D0-facp1*facp_inv +! Following three variables are the derivatives of the square root of eps +! in om1, om2, and om12. + eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv + eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv + eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 +! Evaluate the "asymmetric" factor in the VDW constant, eps3 + eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 +! write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt +! write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, +! & " eps2rt_om12",eps2rt_om12 +! Calculate whole angle-dependent part of epsilon and contributions +! to its derivatives + return + end subroutine sc_angular +!----------------------------------------------------------------------------- +! initialize_p.F +!----------------------------------------------------------------------------- + subroutine int_bounds(total_ints,lower_bound,upper_bound) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.SETUP' + integer :: total_ints,lower_bound,upper_bound,nint + integer,dimension(0:nfgtasks) :: int4proc,sint4proc !(0:max_fg_procs) + integer :: i,nexcess + nint=total_ints/nfgtasks + do i=1,nfgtasks + int4proc(i-1)=nint + enddo + nexcess=total_ints-nint*nfgtasks + do i=1,nexcess + int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1 + enddo + lower_bound=0 + do i=0,fg_rank-1 + lower_bound=lower_bound+int4proc(i) + enddo + upper_bound=lower_bound+int4proc(fg_rank) + lower_bound=lower_bound+1 + return + end subroutine int_bounds +!----------------------------------------------------------------------------- + subroutine int_bounds1(total_ints,lower_bound,upper_bound) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.SETUP' + integer :: total_ints,lower_bound,upper_bound,nint + integer :: nexcess,i + integer,dimension(0:nfgtasks) :: int4proc,sint4proc !(0:max_fg_procs) + nint=total_ints/nfgtasks1 + do i=1,nfgtasks1 + int4proc(i-1)=nint + enddo + nexcess=total_ints-nint*nfgtasks1 + do i=1,nexcess + int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1 + enddo + lower_bound=0 + do i=0,fg_rank1-1 + lower_bound=lower_bound+int4proc(i) + enddo + upper_bound=lower_bound+int4proc(fg_rank1) + lower_bound=lower_bound+1 + return + end subroutine int_bounds1 +!----------------------------------------------------------------------------- +! intcartderiv.F +!----------------------------------------------------------------------------- + subroutine chainbuild_cart +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use control_data +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.TIME1' +! include 'COMMON.IOUNITS' + integer :: j,i,ierror,ierr + real(kind=8) :: time00,time01 +#ifdef MPI + if (nfgtasks.gt.1) then +! write (iout,*) "BCAST in chainbuild_cart" +! call flush(iout) +! Broadcast the order to build the chain and compute internal coordinates +! to the slaves. The slaves receive the order in ERGASTULUM. + time00=MPI_Wtime() +! write (iout,*) "CHAINBUILD_CART: DC before BCAST" +! do i=0,nres +! write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), +! & (dc(j,i+nres),j=1,3) +! enddo + if (fg_rank.eq.0) & + call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_bcast7=time_bcast7+MPI_Wtime()-time00 + time01=MPI_Wtime() + call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION,& + king,FG_COMM,IERR) +! write (iout,*) "CHAINBUILD_CART: DC after BCAST" +! do i=0,nres +! write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), +! & (dc(j,i+nres),j=1,3) +! enddo +! write (iout,*) "End BCAST in chainbuild_cart" +! call flush(iout) + time_bcast=time_bcast+MPI_Wtime()-time00 + time_bcastc=time_bcastc+MPI_Wtime()-time01 + endif +#endif + do j=1,3 + c(j,1)=dc(j,0) + enddo + do i=2,nres + do j=1,3 + c(j,i)=c(j,i-1)+dc(j,i-1) + enddo + enddo + do i=1,nres + do j=1,3 + c(j,i+nres)=c(j,i)+dc(j,i+nres) + enddo + enddo +! write (iout,*) "CHAINBUILD_CART" +! call cartprint + call int_from_cart1(.false.) + return + end subroutine chainbuild_cart +!----------------------------------------------------------------------------- +! intcor.f +!----------------------------------------------------------------------------- + real(kind=8) function alpha(i1,i2,i3) +! +! Calculates the planar angle between atoms (i1), (i2), and (i3). +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +!el local variables + integer :: i1,i2,i3 + real(kind=8) :: x12,x23,y12,y23,z12,z23,vnorm,wnorm,scalar + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + vnorm=dsqrt(x12*x12+y12*y12+z12*z12) + wnorm=dsqrt(x23*x23+y23*y23+z23*z23) + scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) + alpha=arcos(scalar) + return + end function alpha +!----------------------------------------------------------------------------- + real(kind=8) function beta(i1,i2,i3,i4) +! +! Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +!el local variables + integer :: i1,i2,i3,i4 + real(kind=8) :: x12,x23,x34,y12,y23,y34,z12,z23,z34 + real(kind=8) :: wx,wy,wz,wnorm,vx,vy,vz,vnorm,scalar,angle + real(kind=8) :: tx,ty,tz + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + x34=c(1,i4)-c(1,i3) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + y34=c(2,i4)-c(2,i3) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + z34=c(3,i4)-c(3,i3) +!d print '(2i3,3f10.5)',i1,i2,x12,y12,z12 +!d print '(2i3,3f10.5)',i2,i3,x23,y23,z23 +!d print '(2i3,3f10.5)',i3,i4,x34,y34,z34 + wx=-y23*z34+y34*z23 + wy=x23*z34-z23*x34 + wz=-x23*y34+y23*x34 + wnorm=dsqrt(wx*wx+wy*wy+wz*wz) + vx=y12*z23-z12*y23 + vy=-x12*z23+z12*x23 + vz=x12*y23-y12*x23 + vnorm=dsqrt(vx*vx+vy*vy+vz*vz) + if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then + scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) + if (dabs(scalar).gt.1.0D0) & + scalar=0.99999999999999D0*scalar/dabs(scalar) + angle=dacos(scalar) +!d print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, +!d &scalar,angle + else + angle=pi + endif +! if (angle.le.0.0D0) angle=pi+angle + tx=vy*wz-vz*wy + ty=-vx*wz+vz*wx + tz=vx*wy-vy*wx + scalar=tx*x23+ty*y23+tz*z23 + if (scalar.lt.0.0D0) angle=-angle + beta=angle + return + end function beta +!----------------------------------------------------------------------------- + real(kind=8) function dist(i1,i2) +! +! Calculates the distance between atoms (i1) and (i2). +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +!el local variables + integer :: i1,i2 + real(kind=8) :: x12,y12,z12 + x12=c(1,i1)-c(1,i2) + y12=c(2,i1)-c(2,i2) + z12=c(3,i1)-c(3,i2) + dist=dsqrt(x12*x12+y12*y12+z12*z12) + return + end function dist +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- +! local_move.f +!----------------------------------------------------------------------------- + subroutine local_move_init(debug) +!rc implicit none + +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' ! Needed by COMMON.LOCAL +! include 'COMMON.GEO' ! For pi, deg2rad +! include 'COMMON.LOCAL' ! For vbl +! include 'COMMON.LOCMOVE' + +! INPUT arguments + logical :: debug + + +! Determine wheter to do some debugging output + locmove_output=debug + +! Set the init_called flag to 1 + init_called=1 + +! The following are never changed + min_theta=60.D0*deg2rad ! (0,PI) + max_theta=175.D0*deg2rad ! (0,PI) + dmin2=vbl*vbl*2.*(1.-cos(min_theta)) + dmax2=vbl*vbl*2.*(1.-cos(max_theta)) + flag=1.0D300 + small=1.0D-5 + small2=0.5*small*small + +! Not really necessary... + a_n=0 + b_n=0 + res_n=0 + + return + end subroutine local_move_init +!----------------------------------------------------------------------------- + subroutine local_move(n_start, n_end, PHImin, PHImax) +! Perform a local move between residues m and n (inclusive) +! PHImin and PHImax [0,PI] determine the size of the move +! Works on whatever structure is in the variables theta and phi, +! sidechain variables are left untouched +! The final structure is NOT minimized, but both the cartesian +! variables c and the angles are up-to-date at the end (no further +! chainbuild is required) +!rc implicit none + use random,only:ran_number +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.MINIM' +! include 'COMMON.SBRIDGE' +! include 'COMMON.LOCMOVE' + +! External functions +!EL integer move_res +!EL external move_res +!EL double precision ran_number +!EL external ran_number + +! INPUT arguments + integer :: n_start, n_end ! First and last residues to move + real(kind=8) :: PHImin, PHImax ! min/max angles [0,PI] + +! Local variables + integer :: i,j + real(kind=8) :: min,max + integer :: iretcode + + +! Check if local_move_init was called. This assumes that it +! would not be 1 if not explicitely initialized + if (init_called.ne.1) then + write(6,*)' *** local_move_init not called!!!' + stop + endif + +! Quick check for crazy range + if (n_start.gt.n_end .or. n_start.lt.1 .or. n_end.gt.nres) then + write(6,'(a,i3,a,i3)') & + ' *** Cannot make local move between n_start = ',& + n_start,' and n_end = ',n_end + return + endif + +! Take care of end residues first... + if (n_start.eq.1) then +! Move residue 1 (completely random) + theta(3)=ran_number(min_theta,max_theta) + phi(4)=ran_number(-PI,PI) + i=2 + else + i=n_start + endif + if (n_end.eq.nres) then +! Move residue nres (completely random) + theta(nres)=ran_number(min_theta,max_theta) + phi(nres)=ran_number(-PI,PI) + j=nres-1 + else + j=n_end + endif + +! ...then go through all other residues one by one +! Start from the two extremes and converge + call chainbuild + do while (i.le.j) + min=PHImin + max=PHImax +!$$$c Move the first two residues by less than the others +!$$$ if (i-n_start.lt.3) then +!$$$ if (i-n_start.eq.0) then +!$$$ min=0.4*PHImin +!$$$ max=0.4*PHImax +!$$$ else if (i-n_start.eq.1) then +!$$$ min=0.8*PHImin +!$$$ max=0.8*PHImax +!$$$ else if (i-n_start.eq.2) then +!$$$ min=PHImin +!$$$ max=PHImax +!$$$ endif +!$$$ endif + +! The actual move, on residue i + iretcode=move_res(min,max,i) ! Discard iretcode + i=i+1 + + if (i.le.j) then + min=PHImin + max=PHImax +!$$$c Move the last two residues by less than the others +!$$$ if (n_end-j.lt.3) then +!$$$ if (n_end-j.eq.0) then +!$$$ min=0.4*PHImin +!$$$ max=0.4*PHImax +!$$$ else if (n_end-j.eq.1) then +!$$$ min=0.8*PHImin +!$$$ max=0.8*PHImax +!$$$ else if (n_end-j.eq.2) then +!$$$ min=PHImin +!$$$ max=PHImax +!$$$ endif +!$$$ endif + +! The actual move, on residue j + iretcode=move_res(min,max,j) ! Discard iretcode + j=j-1 + endif + enddo + + call int_from_cart(.false.,.false.) + + return + end subroutine local_move +!----------------------------------------------------------------------------- + subroutine output_tabs +! Prints out the contents of a_..., b_..., res_... +! implicit none + +! Includes +! include 'COMMON.GEO' +! include 'COMMON.LOCMOVE' + +! Local variables + integer :: i,j + + write(6,*)'a_...' + write(6,'(8f7.1)')(a_ang(i)*rad2deg,i=0,a_n-1) + write(6,'(8(2x,3l1,2x))')((a_tab(i,j),i=0,2),j=0,a_n-1) + + write(6,*)'b_...' + write(6,'(4f7.1)')(b_ang(i)*rad2deg,i=0,b_n-1) + write(6,'(4(2x,3l1,2x))')((b_tab(i,j),i=0,2),j=0,b_n-1) + + write(6,*)'res_...' + write(6,'(12f7.1)')(res_ang(i)*rad2deg,i=0,res_n-1) + write(6,'(12(2x,3l1,2x))')((res_tab(0,i,j),i=0,2),j=0,res_n-1) + write(6,'(12(2x,3l1,2x))')((res_tab(1,i,j),i=0,2),j=0,res_n-1) + write(6,'(12(2x,3l1,2x))')((res_tab(2,i,j),i=0,2),j=0,res_n-1) + + return + end subroutine output_tabs +!----------------------------------------------------------------------------- + subroutine angles2tab(PHImin,PHImax,n,ang,tab) +! Only uses angles if [0,PI] (but PHImin cannot be 0., +! and PHImax cannot be PI) +! implicit none + +! Includes +! include 'COMMON.GEO' + +! INPUT arguments + real(kind=8) :: PHImin,PHImax + +! OUTPUT arguments + integer :: n + real(kind=8),dimension(0:3) :: ang + logical,dimension(0:2,0:3) :: tab + + + if (PHImin .eq. PHImax) then +! Special case with two 010's + n = 2; + ang(0) = -PHImin; + ang(1) = PHImin; + tab(0,0) = .false. + tab(2,0) = .false. + tab(0,1) = .false. + tab(2,1) = .false. + tab(1,0) = .true. + tab(1,1) = .true. + else if (PHImin .eq. PI) then +! Special case with one 010 + n = 1 + ang(0) = PI + tab(0,0) = .false. + tab(2,0) = .false. + tab(1,0) = .true. + else if (PHImax .eq. 0.) then +! Special case with one 010 + n = 1 + ang(0) = 0. + tab(0,0) = .false. + tab(2,0) = .false. + tab(1,0) = .true. + else +! Standard cases + n = 0 + if (PHImin .gt. 0.) then +! Start of range (011) + ang(n) = PHImin + tab(0,n) = .false. + tab(1,n) = .true. + tab(2,n) = .true. +! End of range (110) + ang(n+1) = -PHImin + tab(0,n+1) = .true. + tab(1,n+1) = .true. + tab(2,n+1) = .false. + n = n+2 + endif + if (PHImax .lt. PI) then +! Start of range (011) + ang(n) = -PHImax + tab(0,n) = .false. + tab(1,n) = .true. + tab(2,n) = .true. +! End of range (110) + ang(n+1) = PHImax + tab(0,n+1) = .true. + tab(1,n+1) = .true. + tab(2,n+1) = .false. + n = n+2 + endif + endif + + return + end subroutine angles2tab +!----------------------------------------------------------------------------- + subroutine minmax_angles(x,y,z,r,n,ang,tab) +! When solutions do not exist, assume all angles +! are acceptable - i.e., initial geometry must be correct +! implicit none + +! Includes +! include 'COMMON.GEO' +! include 'COMMON.LOCMOVE' + +! Input arguments + real(kind=8) :: x,y,z,r + +! Output arguments + integer :: n + real(kind=8),dimension(0:3) :: ang + logical,dimension(0:2,0:3) :: tab + +! Local variables + real(kind=8) :: num, denom, phi + real(kind=8) :: Kmin, Kmax + integer :: i + + + num = x*x + y*y + z*z + denom = x*x + y*y + n = 0 + if (denom .gt. 0.) then + phi = atan2(y,x) + denom = 2.*r*sqrt(denom) + num = num+r*r + Kmin = (num - dmin2)/denom + Kmax = (num - dmax2)/denom + +! Allowed values of K (else all angles are acceptable) +! -1 <= Kmin < 1 +! -1 < Kmax <= 1 + if (Kmin .gt. 1. .or. abs(Kmin-1.) .lt. small2) then + Kmin = -flag + else if (Kmin .lt. -1. .or. abs(Kmin+1.) .lt. small2) then + Kmin = PI + else + Kmin = acos(Kmin) + endif + + if (Kmax .lt. -1. .or. abs(Kmax+1.) .lt. small2) then + Kmax = flag + else if (Kmax .gt. 1. .or. abs(Kmax-1.) .lt. small2) then + Kmax = 0. + else + Kmax = acos(Kmax) + endif + + if (Kmax .lt. Kmin) Kmax = Kmin + + call angles2tab(Kmin, Kmax, n, ang, tab) + +! Add phi and check that angles are within range (-PI,PI] + do i=0,n-1 + ang(i) = ang(i)+phi + if (ang(i) .le. -PI) then + ang(i) = ang(i)+2.*PI + else if (ang(i) .gt. PI) then + ang(i) = ang(i)-2.*PI + endif + enddo + endif + + return + end subroutine minmax_angles +!----------------------------------------------------------------------------- + subroutine construct_tab +! Take a_... and b_... values and produces the results res_... +! x_ang are assumed to be all different (diff > small) +! x_tab(1,i) must be 1 for all i (i.e., all x_ang are acceptable) +! implicit none + +! Includes +! include 'COMMON.LOCMOVE' + +! Local variables + integer :: n_max,i,j,index + logical :: done + real(kind=8) :: phi + + + n_max = a_n + b_n + if (n_max .eq. 0) then + res_n = 0 + return + endif + + do i=0,n_max-1 + do j=0,1 + res_tab(j,0,i) = .true. + res_tab(j,2,i) = .true. + res_tab(j,1,i) = .false. + enddo + enddo + + index = 0 + phi = -flag + done = .false. + do while (.not.done) + res_ang(index) = flag + +! Check a first... + do i=0,a_n-1 + if ((a_ang(i)-phi).gt.small .and. & + a_ang(i) .lt. res_ang(index)) then +! Found a lower angle + res_ang(index) = a_ang(i) +! Copy the values from a_tab into res_tab(0,,) + res_tab(0,0,index) = a_tab(0,i) + res_tab(0,1,index) = a_tab(1,i) + res_tab(0,2,index) = a_tab(2,i) +! Set default values for res_tab(1,,) + res_tab(1,0,index) = .true. + res_tab(1,1,index) = .false. + res_tab(1,2,index) = .true. + else if (abs(a_ang(i)-res_ang(index)).lt.small) then +! Found an equal angle (can only be equal to a b_ang) + res_tab(0,0,index) = a_tab(0,i) + res_tab(0,1,index) = a_tab(1,i) + res_tab(0,2,index) = a_tab(2,i) + endif + enddo +! ...then check b + do i=0,b_n-1 + if ((b_ang(i)-phi).gt.small .and. & + b_ang(i) .lt. res_ang(index)) then +! Found a lower angle + res_ang(index) = b_ang(i) +! Copy the values from b_tab into res_tab(1,,) + res_tab(1,0,index) = b_tab(0,i) + res_tab(1,1,index) = b_tab(1,i) + res_tab(1,2,index) = b_tab(2,i) +! Set default values for res_tab(0,,) + res_tab(0,0,index) = .true. + res_tab(0,1,index) = .false. + res_tab(0,2,index) = .true. + else if (abs(b_ang(i)-res_ang(index)).lt.small) then +! Found an equal angle (can only be equal to an a_ang) + res_tab(1,0,index) = b_tab(0,i) + res_tab(1,1,index) = b_tab(1,i) + res_tab(1,2,index) = b_tab(2,i) + endif + enddo + + if (res_ang(index) .eq. flag) then + res_n = index + done = .true. + else if (index .eq. n_max-1) then + res_n = n_max + done = .true. + else + phi = res_ang(index) ! Store previous angle + index = index+1 + endif + enddo + +! Fill the gaps +! First a... + index = 0 + if (a_n .gt. 0) then + do while (.not.res_tab(0,1,index)) + index=index+1 + enddo + done = res_tab(0,2,index) + do i=index+1,res_n-1 + if (res_tab(0,1,i)) then + done = res_tab(0,2,i) + else + res_tab(0,0,i) = done + res_tab(0,1,i) = done + res_tab(0,2,i) = done + endif + enddo + done = res_tab(0,0,index) + do i=index-1,0,-1 + if (res_tab(0,1,i)) then + done = res_tab(0,0,i) + else + res_tab(0,0,i) = done + res_tab(0,1,i) = done + res_tab(0,2,i) = done + endif + enddo + else + do i=0,res_n-1 + res_tab(0,0,i) = .true. + res_tab(0,1,i) = .true. + res_tab(0,2,i) = .true. + enddo + endif +! ...then b + index = 0 + if (b_n .gt. 0) then + do while (.not.res_tab(1,1,index)) + index=index+1 + enddo + done = res_tab(1,2,index) + do i=index+1,res_n-1 + if (res_tab(1,1,i)) then + done = res_tab(1,2,i) + else + res_tab(1,0,i) = done + res_tab(1,1,i) = done + res_tab(1,2,i) = done + endif + enddo + done = res_tab(1,0,index) + do i=index-1,0,-1 + if (res_tab(1,1,i)) then + done = res_tab(1,0,i) + else + res_tab(1,0,i) = done + res_tab(1,1,i) = done + res_tab(1,2,i) = done + endif + enddo + else + do i=0,res_n-1 + res_tab(1,0,i) = .true. + res_tab(1,1,i) = .true. + res_tab(1,2,i) = .true. + enddo + endif + +! Finally fill the last row with AND operation + do i=0,res_n-1 + do j=0,2 + res_tab(2,j,i) = (res_tab(0,j,i) .and. res_tab(1,j,i)) + enddo + enddo + + return + end subroutine construct_tab +!----------------------------------------------------------------------------- + subroutine construct_ranges(phi_n,phi_start,phi_end) +! Given the data in res_..., construct a table of +! min/max allowed angles +! implicit none + +! Includes +! include 'COMMON.GEO' +! include 'COMMON.LOCMOVE' + +! Output arguments + integer :: phi_n + real(kind=8),dimension(0:11) :: phi_start,phi_end + +! Local variables + logical :: done + integer :: index + + + if (res_n .eq. 0) then +! Any move is allowed + phi_n = 1 + phi_start(0) = -PI + phi_end(0) = PI + else + phi_n = 0 + index = 0 + done = .false. + do while (.not.done) +! Find start of range (01x) + done = .false. + do while (.not.done) + if (res_tab(2,0,index).or.(.not.res_tab(2,1,index))) then + index=index+1 + else + done = .true. + phi_start(phi_n) = res_ang(index) + endif + if (index .eq. res_n) done = .true. + enddo +! If a start was found (index < res_n), find the end of range (x10) +! It may not be found without wrapping around + if (index .lt. res_n) then + done = .false. + do while (.not.done) + if ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) then + index=index+1 + else + done = .true. + endif + if (index .eq. res_n) done = .true. + enddo + if (index .lt. res_n) then +! Found the end of the range + phi_end(phi_n) = res_ang(index) + phi_n=phi_n+1 + index=index+1 + if (index .eq. res_n) then + done = .true. + else + done = .false. + endif + else +! Need to wrap around + done = .true. + phi_end(phi_n) = flag + endif + endif + enddo +! Take care of the last one if need to wrap around + if (phi_end(phi_n) .eq. flag) then + index = 0 + do while ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) + index=index+1 + enddo + phi_end(phi_n) = res_ang(index) + 2.*PI + phi_n=phi_n+1 + endif + endif + + return + end subroutine construct_ranges +!----------------------------------------------------------------------------- + subroutine fix_no_moves(phi) +! implicit none + +! Includes +! include 'COMMON.GEO' +! include 'COMMON.LOCMOVE' + +! Output arguments + real(kind=8) :: phi + +! Local variables + integer :: index + real(kind=8) :: diff,temp + + +! Look for first 01x in gammas (there MUST be at least one) + diff = flag + index = 0 + do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) + index=index+1 + enddo + if (res_ang(index) .le. 0.D0) then ! Make sure it's from PHImax +! Try to increase PHImax + if (index .gt. 0) then + phi = res_ang(index-1) + diff = abs(res_ang(index) - res_ang(index-1)) + endif +! Look for last (corresponding) x10 + index = res_n - 1 + do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) + index=index-1 + enddo + if (index .lt. res_n-1) then + temp = abs(res_ang(index) - res_ang(index+1)) + if (temp .lt. diff) then + phi = res_ang(index+1) + diff = temp + endif + endif + endif + +! If increasing PHImax didn't work, decreasing PHImin +! will (with one exception) +! Look for first x10 (there MUST be at least one) + index = 0 + do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) + index=index+1 + enddo + if (res_ang(index) .lt. 0.D0) then ! Make sure it's from PHImin +! Try to decrease PHImin + if (index .lt. res_n-1) then + temp = abs(res_ang(index) - res_ang(index+1)) + if (res_ang(index+1) .le. 0.D0 .and. temp .lt. diff) then + phi = res_ang(index+1) + diff = temp + endif + endif +! Look for last (corresponding) 01x + index = res_n - 1 + do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) + index=index-1 + enddo + if (index .gt. 0) then + temp = abs(res_ang(index) - res_ang(index-1)) + if (res_ang(index-1) .ge. 0.D0 .and. temp .lt. diff) then + phi = res_ang(index-1) + diff = temp + endif + endif + endif + +! If it still didn't work, it must be PHImax == 0. or PHImin == PI + if (diff .eq. flag) then + index = 0 + if (res_tab(index,1,0) .or. (.not.res_tab(index,1,1)) .or. & + res_tab(index,1,2)) index = res_n - 1 +! This MUST work at this point + if (index .eq. 0) then + phi = res_ang(1) + else + phi = res_ang(index - 1) + endif + endif + + return + end subroutine fix_no_moves +!----------------------------------------------------------------------------- + integer function move_res(PHImin,PHImax,i_move) +! Moves residue i_move (in array c), leaving everything else fixed +! Starting geometry is not checked, it should be correct! +! R(,i_move) is the only residue that will move, but must have +! 1 < i_move < nres (i.e., cannot move ends) +! Whether any output is done is controlled by locmove_output +!rc implicit none + use random,only:ran_number +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.LOCMOVE' + +! External functions +!EL double precision ran_number +!EL external ran_number + +! Input arguments + real(kind=8) :: PHImin,PHImax + integer :: i_move + +! RETURN VALUES: +! 0: move successfull +! 1: Dmin or Dmax had to be modified +! 2: move failed - check your input geometry + + +! Local variables + real(kind=8),dimension(0:2) :: X,Y,Z,Orig + real(kind=8),dimension(0:2) :: P + logical :: no_moves,done + integer :: index,i,j + real(kind=8) :: phi,temp,radius + real(kind=8),dimension(0:11) :: phi_start,phi_end + integer :: phi_n + +! Set up the coordinate system + do i=0,2 + Orig(i)=0.5*(c(i+1,i_move-1)+c(i+1,i_move+1)) ! Position of origin + enddo + + do i=0,2 + Z(i)=c(i+1,i_move+1)-c(i+1,i_move-1) + enddo + temp=sqrt(Z(0)*Z(0)+Z(1)*Z(1)+Z(2)*Z(2)) + do i=0,2 + Z(i)=Z(i)/temp + enddo + + do i=0,2 + X(i)=c(i+1,i_move)-Orig(i) + enddo +! radius is the radius of the circle on which c(,i_move) can move + radius=sqrt(X(0)*X(0)+X(1)*X(1)+X(2)*X(2)) + do i=0,2 + X(i)=X(i)/radius + enddo + + Y(0)=Z(1)*X(2)-X(1)*Z(2) + Y(1)=X(0)*Z(2)-Z(0)*X(2) + Y(2)=Z(0)*X(1)-X(0)*Z(1) + +! Calculate min, max angles coming from dmin, dmax to c(,i_move-2) + if (i_move.gt.2) then + do i=0,2 + P(i)=c(i+1,i_move-2)-Orig(i) + enddo + call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2),& + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2),& + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2),& + radius,a_n,a_ang,a_tab) + else + a_n=0 + endif + +! Calculate min, max angles coming from dmin, dmax to c(,i_move+2) + if (i_move.lt.nres-2) then + do i=0,2 + P(i)=c(i+1,i_move+2)-Orig(i) + enddo + call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2),& + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2),& + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2),& + radius,b_n,b_ang,b_tab) + else + b_n=0 + endif + +! Construct the resulting table for alpha and beta + call construct_tab() + + if (locmove_output) then + print *,'ALPHAS & BETAS TABLE' + call output_tabs() + endif + +! Check that there is at least one possible move + no_moves = .true. + if (res_n .eq. 0) then + no_moves = .false. + else + index = 0 + do while ((index .lt. res_n) .and. no_moves) + if (res_tab(2,1,index)) no_moves = .false. + index=index+1 + enddo + endif + if (no_moves) then + if (locmove_output) print *,' *** Cannot move anywhere' + move_res=2 + return + endif + +! Transfer res_... into a_... + a_n = 0 + do i=0,res_n-1 + if ( (res_tab(2,0,i).neqv.res_tab(2,1,i)) .or. & + (res_tab(2,0,i).neqv.res_tab(2,2,i)) ) then + a_ang(a_n) = res_ang(i) + do j=0,2 + a_tab(j,a_n) = res_tab(2,j,i) + enddo + a_n=a_n+1 + endif + enddo + +! Check that the PHI's are within [0,PI] + if (PHImin .lt. 0. .or. abs(PHImin) .lt. small) PHImin = -flag + if (PHImin .gt. PI .or. abs(PHImin-PI) .lt. small) PHImin = PI + if (PHImax .gt. PI .or. abs(PHImax-PI) .lt. small) PHImax = flag + if (PHImax .lt. 0. .or. abs(PHImax) .lt. small) PHImax = 0. + if (PHImax .lt. PHImin) PHImax = PHImin +! Calculate min and max angles coming from PHImin and PHImax, +! and put them in b_... + call angles2tab(PHImin, PHImax, b_n, b_ang, b_tab) +! Construct the final table + call construct_tab() + + if (locmove_output) then + print *,'FINAL TABLE' + call output_tabs() + endif + +! Check that there is at least one possible move + no_moves = .true. + if (res_n .eq. 0) then + no_moves = .false. + else + index = 0 + do while ((index .lt. res_n) .and. no_moves) + if (res_tab(2,1,index)) no_moves = .false. + index=index+1 + enddo + endif + + if (no_moves) then +! Take care of the case where no solution exists... + call fix_no_moves(phi) + if (locmove_output) then + print *,' *** Had to modify PHImin or PHImax' + print *,'phi: ',phi*rad2deg + endif + move_res=1 + else +! ...or calculate the solution +! Construct phi_start/phi_end arrays + call construct_ranges(phi_n, phi_start, phi_end) +! Choose random angle phi in allowed range(s) + temp = 0. + do i=0,phi_n-1 + temp = temp + phi_end(i) - phi_start(i) + enddo + phi = ran_number(phi_start(0),phi_start(0)+temp) + index = 0 + done = .false. + do while (.not.done) + if (phi .lt. phi_end(index)) then + done = .true. + else + index=index+1 + endif + if (index .eq. phi_n) then + done = .true. + else if (.not.done) then + phi = phi + phi_start(index) - phi_end(index-1) + endif + enddo + if (index.eq.phi_n) phi=phi_end(phi_n-1) ! Fix numerical errors + if (phi .gt. PI) phi = phi-2.*PI + + if (locmove_output) then + print *,'ALLOWED RANGE(S)' + do i=0,phi_n-1 + print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg + enddo + print *,'phi: ',phi*rad2deg + endif + move_res=0 + endif + +! Re-use radius as temp variable + temp=radius*cos(phi) + radius=radius*sin(phi) + do i=0,2 + c(i+1,i_move)=Orig(i)+temp*X(i)+radius*Y(i) + enddo + + return + end function move_res +!----------------------------------------------------------------------------- + subroutine loc_test +!rc implicit none + +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.LOCMOVE' + +! External functions +!EL integer move_res +!EL external move_res + +! Local variables + integer :: i,j,imov + integer :: phi_n + real(kind=8),dimension(0:11) :: phi_start,phi_end + real(kind=8) :: phi + real(kind=8),dimension(0:2,0:5) :: R + + locmove_output=.true. + +! call angles2tab(30.*deg2rad,70.*deg2rad,a_n,a_ang,a_tab) +! call angles2tab(80.*deg2rad,130.*deg2rad,b_n,b_ang,b_tab) +! call minmax_angles(0.D0,3.8D0,0.D0,3.8D0,b_n,b_ang,b_tab) +! call construct_tab +! call output_tabs + +! call construct_ranges(phi_n,phi_start,phi_end) +! do i=0,phi_n-1 +! print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg +! enddo + +! call fix_no_moves(phi) +! print *,'NO MOVES FOUND, BEST PHI IS',phi*rad2deg + + R(0,0)=0.D0 + R(1,0)=0.D0 + R(2,0)=0.D0 + R(0,1)=0.D0 + R(1,1)=-cos(28.D0*deg2rad) + R(2,1)=-0.5D0-sin(28.D0*deg2rad) + R(0,2)=0.D0 + R(1,2)=0.D0 + R(2,2)=-0.5D0 + R(0,3)=cos(30.D0*deg2rad) + R(1,3)=0.D0 + R(2,3)=0.D0 + R(0,4)=0.D0 + R(1,4)=0.D0 + R(2,4)=0.5D0 + R(0,5)=0.D0 + R(1,5)=cos(26.D0*deg2rad) + R(2,5)=0.5D0+sin(26.D0*deg2rad) + do i=1,5 + do j=0,2 + R(j,i)=vbl*R(j,i) + enddo + enddo +! i=move_res(R(0,1),0.D0*deg2rad,180.D0*deg2rad) + imov=2 + i=move_res(0.D0*deg2rad,180.D0*deg2rad,imov) + print *,'RETURNED ',i + print *,(R(i,3)/vbl,i=0,2) + + return + end subroutine loc_test +#endif +!----------------------------------------------------------------------------- +! matmult.f +!----------------------------------------------------------------------------- + subroutine MATMULT(A1,A2,A3) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +!el local variables + integer :: i,j,k + real(kind=8) :: A3IJ + + real(kind=8),DIMENSION(3,3) :: A1,A2,A3 + real(kind=8),DIMENSION(3,3) :: AI3 + DO 1 I=1,3 + DO 2 J=1,3 + A3IJ=0.0 + DO 3 K=1,3 + 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) + AI3(I,J)=A3IJ + 2 CONTINUE + 1 CONTINUE + DO 4 I=1,3 + DO 4 J=1,3 + 4 A3(I,J)=AI3(I,J) + return + end subroutine MATMULT +!----------------------------------------------------------------------------- +! readpdb.F +!----------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use control_data,only:out1file +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.NAMES' +! include 'COMMON.CONTROL' +! include 'COMMON.SETUP' + character(len=3) :: seq,res +! character*5 atom + character(len=80) :: card + real(kind=8),dimension(3,20) :: sccor + integer :: i,j,iti !el rescode, + logical :: lside,lprn + real(kind=8) :: di,cosfac,sinfac + integer :: nres2 + nres2=2*nres + + if(me.eq.king.or..not.out1file)then + if (lprn) then + write (iout,'(/a)') & + 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta',& + ' Gamma',' Dsc_id',' Dsc',' Alpha',& + ' Beta ' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta',& + ' Gamma' + endif + endif + endif + do i=1,nres-1 +!in wham do i=1,nres + iti=itype(i) + if (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i +!test stop + endif +!#ifndef WHAM_RUN + vbld(i+1)=dist(i,i+1) + vbld_inv(i+1)=1.0d0/vbld(i+1) +!#endif + if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + enddo +!el ----- +!#ifdef WHAM_RUN +! if (itype(1).eq.ntyp1) then +! do j=1,3 +! c(j,1)=c(j,2)+(c(j,3)-c(j,4)) +! enddo +! endif +! if (itype(nres).eq.ntyp1) then +! do j=1,3 +! c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3)) +! enddo +! endif +!#endif +! if (unres_pdb) then +! if (itype(1).eq.21) then +! theta(3)=90.0d0*deg2rad +! phi(4)=180.0d0*deg2rad +! vbld(2)=3.8d0 +! vbld_inv(2)=1.0d0/vbld(2) +! endif +! if (itype(nres).eq.21) then +! theta(nres)=90.0d0*deg2rad +! phi(nres)=180.0d0*deg2rad +! vbld(nres)=3.8d0 +! vbld_inv(nres)=1.0d0/vbld(2) +! endif +! endif + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,nres2+2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i) & + +(c(j,i+1)-c(j,i))*vbld_inv(i+1)) +! in wham c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1) + enddo + iti=itype(i) + di=dist(i,nres+i) +!#ifndef WHAM_RUN +! 10/03/12 Adam: Correction for zero SC-SC bond length + if (itype(i).ne.10 .and. itype(i).ne.ntyp1 .and. di.eq.0.0d0) & + di=dsc(itype(i)) + vbld(i+nres)=di + if (itype(i).ne.10) then + vbld_inv(i+nres)=1.0d0/di + else + vbld_inv(i+nres)=0.0d0 + endif +!#endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,nres2+2) + omeg(i)=beta(nres+i,i,nres2+2,i+1) + endif + if(me.eq.king.or..not.out1file)then + if (lprn) & + write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i),& + rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i),& + rad2deg*alph(i),rad2deg*omeg(i) + endif + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) & + write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1),& + rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end subroutine int_from_cart +!----------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use control_data,only:out1file +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.NAMES' +! include 'COMMON.CONTROL' +! include 'COMMON.SETUP' + real(kind=8),dimension(3) :: x_prime,y_prime,z_prime + logical :: lprn +!el local variables + integer :: i,j,it,iti + real(kind=8) :: cosfac2,sinfac2,xx,yy,zz,cosfac,sinfac + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10) then + do j=1,3 + dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) + enddo + else + do j=1,3 + dc_norm(j,i+nres)=0.0d0 + enddo + endif + enddo + do i=2,nres-1 + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + + if ((it.ne.10).and.(it.ne.ntyp1)) then +!el if (it.ne.10) then +! +! Compute the axes of tghe local cartesian coordinates system; store in +! x_prime, y_prime and z_prime +! + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + call vecpr(x_prime,y_prime,z_prime) +! +! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +! to local coordinate system. Store in xx, yy, zz. +! + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) & + write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),& + yyref(i),zzref(i) + enddo + endif + + return + end subroutine sc_loc_geom +!----------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' + integer :: i,j,ires,nscat + real(kind=8),dimension(3,20) :: sccor + real(kind=8) :: sccmj + do j=1,3 + sccmj=0.0D0 + do i=1,nscat + sccmj=sccmj+sccor(j,i) + enddo + dc(j,ires)=sccmj/nscat + enddo + return + end subroutine sccenter +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- + subroutine bond_regular + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CALC' +! include 'COMMON.INTERACT' +! include 'COMMON.CHAIN' + do i=1,nres-1 + vbld(i+1)=vbl + vbld_inv(i+1)=1.0d0/vbld(i+1) + vbld(i+1+nres)=dsc(itype(i+1)) + vbld_inv(i+1+nres)=dsc_inv(itype(i+1)) +! print *,vbld(i+1),vbld(i+1+nres) + enddo + return + end subroutine bond_regular +#endif +!----------------------------------------------------------------------------- +! refsys.f +!----------------------------------------------------------------------------- + subroutine refsys(i2,i3,i4,e1,e2,e3,fail) +! This subroutine calculates unit vectors of a local reference system +! defined by atoms (i2), (i3), and (i4). The x axis is the axis from +! atom (i3) to atom (i2), and the xy plane is the plane defined by atoms +! (i2), (i3), and (i4). z axis is directed according to the sign of the +! vector product (i3)-(i2) and (i3)-(i4). Sets fail to .true. if atoms +! (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4) +! form a linear fragment. Returns vectors e1, e2, and e3. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + logical :: fail + real(kind=8),dimension(3) :: e1,e2,e3 + real(kind=8),dimension(3) :: u,z +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' + real(kind=8) :: coinc=1.0D-13,align=1.0D-13 +!el local variables + integer :: i,i1,i2,i3,i4 + real(kind=8) :: v1,v2,v3,s1,s2,zi,ui,anorm + fail=.false. + s1=0.0 + s2=0.0 + do 1 i=1,3 + zi=c(i,i2)-c(i,i3) + ui=c(i,i4)-c(i,i3) + s1=s1+zi*zi + s2=s2+ui*ui + z(i)=zi + 1 u(i)=ui + s1=sqrt(s1) + s2=sqrt(s2) + if (s1.gt.coinc) goto 2 + write (iout,1000) i2,i3,i1 + fail=.true. +! do 3 i=1,3 +! 3 c(i,i1)=0.0D0 + return + 2 if (s2.gt.coinc) goto 4 + write(iout,1000) i3,i4,i1 + fail=.true. + do 5 i=1,3 + 5 c(i,i1)=0.0D0 + return + 4 s1=1.0/s1 + s2=1.0/s2 + v1=z(2)*u(3)-z(3)*u(2) + v2=z(3)*u(1)-z(1)*u(3) + v3=z(1)*u(2)-z(2)*u(1) + anorm=dsqrt(v1*v1+v2*v2+v3*v3) + if (anorm.gt.align) goto 6 + write (iout,1010) i2,i3,i4,i1 + fail=.true. +! do 7 i=1,3 +! 7 c(i,i1)=0.0D0 + return + 6 anorm=1.0D0/anorm + e3(1)=v1*anorm + e3(2)=v2*anorm + e3(3)=v3*anorm + e1(1)=z(1)*s1 + e1(2)=z(2)*s1 + e1(3)=z(3)*s1 + e2(1)=e1(3)*e3(2)-e1(2)*e3(3) + e2(2)=e1(1)*e3(3)-e1(3)*e3(1) + e2(3)=e1(2)*e3(1)-e1(1)*e3(2) + 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.',& + 'coordinates of atom',i4,' are set to zero.') + 1010 format (/1x,' * * * Error - atoms',2(i4,2h, ),i4,' form a linear',& + ' fragment. coordinates of atom',i4,' are set to zero.') + return + end subroutine refsys +!----------------------------------------------------------------------------- +! int_to_cart.f +!----------------------------------------------------------------------------- + subroutine int_to_cart +!-------------------------------------------------------------- +! This subroutine converts the energy derivatives from internal +! coordinates to cartesian coordinates +!------------------------------------------------------------- +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' +! include 'COMMON.SCCOR' +! calculating dE/ddc1 +!el local variables + integer :: j,i + if (nres.lt.3) go to 18 + do j=1,3 + gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4) & + +gloc(nres-2,icg)*dtheta(j,1,3) + if(itype(2).ne.10) then + gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+ & + gloc(ialph(2,1)+nside,icg)*domega(j,1,2) + endif + enddo +! Calculating the remainder of dE/ddc2 + do j=1,3 + gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+ & + gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4) + if(itype(2).ne.10) then + gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+ & + gloc(ialph(2,1)+nside,icg)*domega(j,2,2) + endif + if(itype(3).ne.10) then + gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+ & + gloc(ialph(3,1)+nside,icg)*domega(j,1,3) + endif + if(nres.gt.4) then + gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5) + endif + enddo +! If there are only five residues + if(nres.eq.5) then + do j=1,3 + gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)* & + dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)* & + dtheta(j,1,5) + if(itype(3).ne.10) then + gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)* & + dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3) + endif + if(itype(4).ne.10) then + gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)* & + dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4) + endif + enddo + endif +! If there are more than five residues + if(nres.gt.5) then + do i=3,nres-3 + do j=1,3 + gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1) & + +gloc(i-1,icg)*dphi(j,2,i+2)+ & + gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+ & + gloc(nres+i-3,icg)*dtheta(j,1,i+2) + if(itype(i).ne.10) then + gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+ & + gloc(ialph(i,1)+nside,icg)*domega(j,2,i) + endif + if(itype(i+1).ne.10) then + gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1) & + +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1) + endif + enddo + enddo + endif +! Setting dE/ddnres-2 + if(nres.gt.5) then + do j=1,3 + gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)* & + dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres) & + +gloc(2*nres-6,icg)* & + dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres) + if(itype(nres-2).ne.10) then + gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)* & + dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)* & + domega(j,2,nres-2) + endif + if(itype(nres-1).ne.10) then + gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)* & + dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* & + domega(j,1,nres-1) + endif + enddo + endif +! Settind dE/ddnres-1 + do j=1,3 + gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+ & + gloc(2*nres-5,icg)*dtheta(j,2,nres) + if(itype(nres-1).ne.10) then + gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)* & + dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* & + domega(j,2,nres-1) + endif + enddo +! The side-chain vector derivatives + do i=2,nres-1 + if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i) & + +gloc(ialph(i,1)+nside,icg)*domega(j,3,i) + enddo + endif + enddo +!---------------------------------------------------------------------- +! INTERTYP=1 SC...Ca...Ca...Ca +! INTERTYP=2 Ca...Ca...Ca...SC +! INTERTYP=3 SC...Ca...Ca...SC +! calculating dE/ddc1 + 18 continue +! do i=1,nres +! gloc(i,icg)=0.0D0 +! write (iout,*) "poczotkoawy",i,gloc_sc(1,i,icg) +! enddo + if (nres.lt.2) return + if ((nres.lt.3).and.(itype(1).eq.10)) return + if ((itype(1).ne.10).and.(itype(1).ne.ntyp1)) then + do j=1,3 +!c Derviative was calculated for oposite vector of side chain therefore +! there is "-" sign before gloc_sc + gxcart(j,1)=gxcart(j,1)-gloc_sc(1,0,icg)* & + dtauangle(j,1,1,3) + gcart(j,1)=gcart(j,1)+gloc_sc(1,0,icg)* & + dtauangle(j,1,2,3) + if ((itype(2).ne.10).and.(itype(2).ne.ntyp1)) then + gxcart(j,1)= gxcart(j,1) & + -gloc_sc(3,0,icg)*dtauangle(j,3,1,3) + gcart(j,1)=gcart(j,1)+gloc_sc(3,0,icg)* & + dtauangle(j,3,2,3) + endif + enddo + endif + if ((nres.ge.3).and.(itype(3).ne.10).and.(itype(3).ne.ntyp1)) & + then + do j=1,3 + gcart(j,1)=gcart(j,1)+gloc_sc(2,1,icg)*dtauangle(j,2,1,4) + enddo + endif +! As potetnial DO NOT depend on omicron anlge their derivative is +! ommited +! & +gloc_sc(intertyp,nres-2,icg)*dtheta(j,1,3) + +! Calculating the remainder of dE/ddc2 + do j=1,3 + if((itype(2).ne.10).and.(itype(2).ne.ntyp1)) then + if (itype(1).ne.10) gxcart(j,2)=gxcart(j,2)+ & + gloc_sc(3,0,icg)*dtauangle(j,3,3,3) + if ((itype(3).ne.10).and.(nres.ge.3).and.(itype(3).ne.ntyp1)) & + then + gxcart(j,2)=gxcart(j,2)-gloc_sc(3,1,icg)*dtauangle(j,3,1,4) +!c the - above is due to different vector direction + gcart(j,2)=gcart(j,2)+gloc_sc(3,1,icg)*dtauangle(j,3,2,4) + endif + if (nres.gt.3) then + gxcart(j,2)=gxcart(j,2)-gloc_sc(1,1,icg)*dtauangle(j,1,1,4) +!c the - above is due to different vector direction + gcart(j,2)=gcart(j,2)+gloc_sc(1,1,icg)*dtauangle(j,1,2,4) +! write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,2,4),"gcart" +! write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,1,4),"gx" + endif + endif + if ((itype(1).ne.10).and.(itype(1).ne.ntyp1)) then + gcart(j,2)=gcart(j,2)+gloc_sc(1,0,icg)*dtauangle(j,1,3,3) +! write(iout,*) gloc_sc(1,0,icg),dtauangle(j,1,3,3) + endif + if ((itype(3).ne.10).and.(nres.ge.3)) then + gcart(j,2)=gcart(j,2)+gloc_sc(2,1,icg)*dtauangle(j,2,2,4) +! write(iout,*) gloc_sc(2,1,icg),dtauangle(j,2,2,4) + endif + if ((itype(4).ne.10).and.(nres.ge.4)) then + gcart(j,2)=gcart(j,2)+gloc_sc(2,2,icg)*dtauangle(j,2,1,5) +! write(iout,*) gloc_sc(2,2,icg),dtauangle(j,2,1,5) + endif + +! write(iout,*) gcart(j,2),itype(2),itype(1),itype(3), "gcart2" + enddo +! If there are more than five residues + if(nres.ge.5) then + do i=3,nres-2 + do j=1,3 +! write(iout,*) "before", gcart(j,i) + if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + gxcart(j,i)=gxcart(j,i)+gloc_sc(2,i-2,icg) & + *dtauangle(j,2,3,i+1) & + -gloc_sc(1,i-1,icg)*dtauangle(j,1,1,i+2) + gcart(j,i)=gcart(j,i)+gloc_sc(1,i-1,icg) & + *dtauangle(j,1,2,i+2) +! write(iout,*) "new",j,i, +! & gcart(j,i),gloc_sc(1,i-1,icg),dtauangle(j,1,2,i+2) + if (itype(i-1).ne.10) then + gxcart(j,i)=gxcart(j,i)+gloc_sc(3,i-2,icg) & + *dtauangle(j,3,3,i+1) + endif + if (itype(i+1).ne.10) then + gxcart(j,i)=gxcart(j,i)-gloc_sc(3,i-1,icg) & + *dtauangle(j,3,1,i+2) + gcart(j,i)=gcart(j,i)+gloc_sc(3,i-1,icg) & + *dtauangle(j,3,2,i+2) + endif + endif + if (itype(i-1).ne.10) then + gcart(j,i)=gcart(j,i)+gloc_sc(1,i-2,icg)* & + dtauangle(j,1,3,i+1) + endif + if (itype(i+1).ne.10) then + gcart(j,i)=gcart(j,i)+gloc_sc(2,i-1,icg)* & + dtauangle(j,2,2,i+2) +! write(iout,*) "numer",i,gloc_sc(2,i-1,icg), +! & dtauangle(j,2,2,i+2) + endif + if (itype(i+2).ne.10) then + gcart(j,i)=gcart(j,i)+gloc_sc(2,i,icg)* & + dtauangle(j,2,1,i+3) + endif + enddo + enddo + endif +! Setting dE/ddnres-1 + if(nres.ge.4) then + do j=1,3 + if ((itype(nres-1).ne.10).and.(itype(nres-1).ne.ntyp1)) then + gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(2,nres-3,icg) & + *dtauangle(j,2,3,nres) +! write (iout,*) "gxcart(nres-1)", gloc_sc(2,nres-3,icg), +! & dtauangle(j,2,3,nres), gxcart(j,nres-1) + if (itype(nres-2).ne.10) then + gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(3,nres-3,icg) & + *dtauangle(j,3,3,nres) + endif + if ((itype(nres).ne.10).and.(itype(nres).ne.ntyp1)) then + gxcart(j,nres-1)=gxcart(j,nres-1)-gloc_sc(3,nres-2,icg) & + *dtauangle(j,3,1,nres+1) + gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(3,nres-2,icg) & + *dtauangle(j,3,2,nres+1) + endif + endif + if ((itype(nres-2).ne.10).and.(itype(nres-2).ne.ntyp1)) then + gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(1,nres-3,icg)* & + dtauangle(j,1,3,nres) + endif + if ((itype(nres).ne.10).and.(itype(nres).ne.ntyp1)) then + gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(2,nres-2,icg)* & + dtauangle(j,2,2,nres+1) +! write (iout,*) "gcart(nres-1)", gloc_sc(2,nres-2,icg), +! & dtauangle(j,2,2,nres+1), itype(nres-1),itype(nres) + endif + enddo + endif +! Settind dE/ddnres + if ((nres.ge.3).and.(itype(nres).ne.10).and. & + (itype(nres).ne.ntyp1))then + do j=1,3 + gxcart(j,nres)=gxcart(j,nres)+gloc_sc(3,nres-2,icg) & + *dtauangle(j,3,3,nres+1)+gloc_sc(2,nres-2,icg) & + *dtauangle(j,2,3,nres+1) + enddo + endif +! The side-chain vector derivatives + return + end subroutine int_to_cart +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + subroutine gen_dist_constr +! Generate CA distance constraints. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.LOCAL' +! include 'COMMON.NAMES' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' +! include 'COMMON.DBASE' +! include 'COMMON.THREAD' +! include 'COMMON.TIME1' +! integer :: itype_pdb !(maxres) +! common /pizda/ itype_pdb(nres) + character(len=2) :: iden +!el local variables + integer :: i,j +!d print *,'gen_dist_constr: nnt=',nnt,' nct=',nct +!d write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, +!d & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq, +!d & ' nsup',nsup + do i=nstart_sup,nstart_sup+nsup-1 +!d write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)), +!d & ' seq_pdb', restyp(itype_pdb(i)) + do j=i+2,nstart_sup+nsup-1 + nhpb=nhpb+1 + ihpb(nhpb)=i+nstart_seq-nstart_sup + jhpb(nhpb)=j+nstart_seq-nstart_sup + forcon(nhpb)=weidis + dhpb(nhpb)=dist(i,j) + enddo + enddo +!d write (iout,'(a)') 'Distance constraints:' +!d do i=nss+1,nhpb +!d ii=ihpb(i) +!d jj=jhpb(i) +!d iden='CA' +!d if (ii.gt.nres) then +!d iden='SC' +!d ii=ii-nres +!d jj=jj-nres +!d endif +!d write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)') +!d & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj, +!d & dhpb(i),forcon(i) +!d enddo +! deallocate(itype_pdb) + + return + end subroutine gen_dist_constr +#endif +!----------------------------------------------------------------------------- +! cartprint.f +!----------------------------------------------------------------------------- + subroutine cartprint + + use geometry_data, only: c + use energy_data, only: itype +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' + integer :: i + + write (iout,100) + do i=1,nres + write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),& + c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) + enddo + 100 format (//' alpha-carbon coordinates ',& + ' centroid coordinates'/ & + ' ', 6X,'X',11X,'Y',11X,'Z',& + 10X,'X',11X,'Y',11X,'Z') + 110 format (a,'(',i3,')',6f12.5) + return + end subroutine cartprint +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + subroutine alloc_geo_arrays +!EL Allocation of tables used by module energy + + integer :: i,j,nres2 + nres2=2*nres +! commom.bounds +! common /bounds/ + allocate(phibound(2,nres+2)) !(2,maxres) +!---------------------- +! commom.chain +! common /chain/ in molread +! real(kind=8),dimension(:,:),allocatable :: c !(3,maxres2+2) +! real(kind=8),dimension(:,:),allocatable :: dc + allocate(dc_old(3,0:nres2)) +! if(.not.allocated(dc_norm2)) allocate(dc_norm2(3,0:nres2+2)) !(3,0:maxres2) + if(.not.allocated(dc_norm2)) then + allocate(dc_norm2(3,0:nres2+2)) !(3,0:maxres2) + dc_norm2(:,:)=0.d0 + endif +! +!el if(.not.allocated(dc_norm)) +!elwrite(iout,*) "jestem w alloc geo 1" + if(.not.allocated(dc_norm)) then + allocate(dc_norm(3,0:nres2+2)) !(3,0:maxres2) + dc_norm(:,:)=0.d0 + endif +!elwrite(iout,*) "jestem w alloc geo 1" + allocate(xloc(3,nres),xrot(3,nres)) +!elwrite(iout,*) "jestem w alloc geo 1" + xloc(:,:)=0.0D0 +!elwrite(iout,*) "jestem w alloc geo 1" + allocate(dc_work(6*nres)) !(MAXRES6) maxres6=6*maxres +! common /rotmat/ + allocate(t(3,3,nres),r(3,3,nres)) + allocate(prod(3,3,nres),rt(3,3,nres)) !(3,3,maxres) +! common /refstruct/ + if(.not.allocated(cref)) allocate(cref(3,nres2+2,maxperm)) !(3,maxres2+2,maxperm) +!elwrite(iout,*) "jestem w alloc geo 2" + allocate(crefjlee(3,nres2+2)) !(3,maxres2+2) + if(.not.allocated(chain_rep)) allocate(chain_rep(3,nres2+2,maxsym)) !(3,maxres2+2,maxsym) + if(.not.allocated(tabperm)) allocate(tabperm(maxperm,maxsym)) !(maxperm,maxsym) +! common /from_zscore/ in module.compare +!---------------------- +! common.local +! Inverses of the actual virtual bond lengths +! common /invlen/ in io_conf: molread or readpdb +! real(kind=8),dimension(:),allocatable :: vbld_inv !(maxres2) +!---------------------- +! common.var +! Store the geometric variables in the following COMMON block. +! common /var/ in readpdb or ... + if(.not.allocated(theta)) allocate(theta(nres+2)) + if(.not.allocated(phi)) allocate(phi(nres+2)) + if(.not.allocated(alph)) allocate(alph(nres+2)) + if(.not.allocated(omeg)) allocate(omeg(nres+2)) + if(.not.allocated(thetaref)) allocate(thetaref(nres+2)) + if(.not.allocated(phiref)) allocate(phiref(nres+2)) + if(.not.allocated(costtab)) allocate(costtab(nres)) + if(.not.allocated(sinttab)) allocate(sinttab(nres)) + if(.not.allocated(cost2tab)) allocate(cost2tab(nres)) + if(.not.allocated(sint2tab)) allocate(sint2tab(nres)) +! real(kind=8),dimension(:),allocatable :: vbld !(2*maxres) in io_conf: molread or readpdb + allocate(omicron(2,nres+2)) !(2,maxres) + allocate(tauangle(3,nres+2)) !(3,maxres) +!elwrite(iout,*) "jestem w alloc geo 3" + if(.not.allocated(xxtab)) allocate(xxtab(nres)) + if(.not.allocated(yytab)) allocate(yytab(nres)) + if(.not.allocated(zztab)) allocate(zztab(nres)) !(maxres) + if(.not.allocated(xxref)) allocate(xxref(nres)) + if(.not.allocated(yyref)) allocate(yyref(nres)) + if(.not.allocated(zzref)) allocate(zzref(nres)) !(maxres) + allocate(ialph(nres,2)) !(maxres,2) + ialph(:,1)=0 + ialph(:,2)=0 + allocate(ivar(4*nres2)) !(4*maxres2) + +#if defined(WHAM_RUN) || defined(CLUSTER) + allocate(vbld(2*nres)) + vbld(:)=0.d0 + allocate(vbld_inv(2*nres)) + vbld_inv(:)=0.d0 +#endif + + return + end subroutine alloc_geo_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module geometry diff --git a/source/unres/geometry.f90 b/source/unres/geometry.f90 deleted file mode 100644 index 0f3febc..0000000 --- a/source/unres/geometry.f90 +++ /dev/null @@ -1,3597 +0,0 @@ - module geometry -!----------------------------------------------------------------------------- - use io_units - use names - use math - use MPI_data - use geometry_data - use control_data - use energy_data - implicit none -!----------------------------------------------------------------------------- -! commom.bounds -! common /bounds/ -!----------------------------------------------------------------------------- -! commom.chain -! common /chain/ -! common /rotmat/ - real(kind=8),dimension(:,:,:),allocatable :: t,r !(3,3,maxres) -!----------------------------------------------------------------------------- -! common.geo -! common /geo/ -!----------------------------------------------------------------------------- -! common.locmove -! Variables (set in init routine) never modified by local_move -! common /loc_const/ - integer :: init_called - logical :: locmove_output - real(kind=8) :: min_theta, max_theta - real(kind=8) :: dmin2,dmax2 - real(kind=8) :: flag,small,small2 -! Workspace for local_move -! common /loc_work/ - integer :: a_n,b_n,res_n - real(kind=8),dimension(0:7) :: a_ang - real(kind=8),dimension(0:3) :: b_ang - real(kind=8),dimension(0:11) :: res_ang - logical,dimension(0:2,0:7) :: a_tab - logical,dimension(0:2,0:3) :: b_tab - logical,dimension(0:2,0:2,0:11) :: res_tab -!----------------------------------------------------------------------------- -! integer,dimension(:),allocatable :: itype_pdb !(maxres) initialize in molread -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! arcos.f -!----------------------------------------------------------------------------- - real(kind=8) function ARCOS(X) -! implicit real*8 (a-h,o-z) -! include 'COMMON.GEO' -!el local variables - real(kind=8) :: x - IF (DABS(X).LT.1.0D0) GOTO 1 - ARCOS=PIPOL*(1.0d0-DSIGN(1.0D0,X)) - RETURN - 1 ARCOS=DACOS(X) - return - end function ARCOS -!----------------------------------------------------------------------------- -! chainbuild.F -!----------------------------------------------------------------------------- - subroutine chainbuild -! -! Build the virtual polypeptide chain. Side-chain centroids are moveable. -! As of 2/17/95. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' - logical :: lprn -!el local variables - integer :: i,j - real(kind=8) :: be,be1,alfai - integer :: nres2 - nres2=2*nres -! Set lprn=.true. for debugging - lprn = .false. -! -! Define the origin and orientation of the coordinate system and locate the -! first three CA's and SC(2). -! -!elwrite(iout,*)"in chainbuild" - call orig_frame -!elwrite(iout,*)"after orig_frame" -! -! Build the alpha-carbon chain. -! - do i=4,nres - call locate_next_res(i) - enddo -!elwrite(iout,*)"after locate_next_res" -! -! First and last SC must coincide with the corresponding CA. -! - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -! -! Temporary diagnosis -! - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,nres2+2)=0.5D0*(c(j,i-1)+c(j,i+1)) !maxres2=2*maxres - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,nres2+2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i),& - alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,nres2+2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end subroutine chainbuild -!----------------------------------------------------------------------------- - subroutine orig_frame -! -! Define the origin and orientation of the coordinate system and locate -! the first three atoms. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -!el local variables - integer :: i,j - real(kind=8) :: cost,sint - -!el allocate(t(3,3,nres)) !(3,3,maxres) -!el allocate(r(3,3,nres)) !(3,3,maxres) -!el allocate(rt(3,3,nres)) !(3,3,maxres) -!el allocate(dc_norm(3,0:2*nres)) !(3,0:maxres2) -!el allocate(prod(3,3,nres)) !(3,3,maxres) - - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,0)=0.0d0 - dc(2,0)=0.0D0 - dc(3,0)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,0)=0.0D0 - dc_norm(2,0)=0.0D0 - dc_norm(3,0)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end subroutine orig_frame -!----------------------------------------------------------------------------- - subroutine locate_next_res(i) -! -! Locate CA(i) and SC(i-1) -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! -! Define the rotation matrices corresponding to CA(i) -! -!el local variables - integer :: i,j - real(kind=8) :: theti,phii - real(kind=8) :: cost,sint,cosphi,sinphi -#ifdef OSF -#ifdef WHAM_RUN - theti=theta(i) - icrc=0 - call proc_proc(theti,icrc) - if(icrc.eq.1)theti=100.0 - phii=phi(i) - icrc=0 - call proc_proc(phii,icrc) - if(icrc.eq.1)phii=180.0 -#else - theti=theta(i) - if (theti.ne.theti) theti=100.0 - phii=phi(i) - if (phii.ne.phii) phii=180.0 -#endif -#else - theti=theta(i) - phii=phi(i) -#endif - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -! Define the matrices of the rotation about the virtual-bond valence angles -! theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -! program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -!d print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -! -! Now calculate the coordinates of SC(i-1) -! - call locate_side_chain(i-1) - return - end subroutine locate_next_res -!----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -! -! Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' - integer :: i,j,k - real(kind=8),dimension(3) :: xx - real(kind=8) :: alphi,omegi,theta2 - real(kind=8) :: dsci,dsci_inv,sinalphi,cosalphi,cosomegi,sinomegi - real(kind=8) :: xp,yp,zp,cost2,sint2,rj -! dsci=dsc(itype(i)) -! dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) -#ifdef WHAM_RUN -! detecting NaNQ - icrc=0 - call proc_proc(alphi,icrc) - if(icrc.eq.1)alphi=100.0 - icrc=0 - call proc_proc(omegi,icrc) - if(icrc.eq.1)omegi=-100.0 -#else - if (alphi.ne.alphi) alphi=100.0 - if (omegi.ne.omegi) omegi=-100.0 -#endif -#else - alphi=alph(i) - omegi=omeg(i) -#endif - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -! Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -! X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -!d print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -!d & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -! Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end subroutine locate_side_chain -!----------------------------------------------------------------------------- -! checkder_p.F -!----------------------------------------------------------------------------- - subroutine int_from_cart1(lprn) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer :: ierror -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' -! include 'COMMON.LOCAL' -! include 'COMMON.NAMES' -! include 'COMMON.SETUP' -! include 'COMMON.TIME1' - logical :: lprn -!el local variables - integer :: i,j - real(kind=8) :: dnorm1,dnorm2,be - integer :: nres2 - nres2=2*nres - if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' -#ifdef TIMING - time01=MPI_Wtime() -#endif - -#ifdef WHAM_RUN - vbld(nres+1)=0.0d0 -!write(iout,*)"geometry warring, vbld=",(vbld(i),i=1,nres+1) - vbld(2*nres)=0.0d0 - vbld_inv(nres+1)=0.0d0 - vbld_inv(2*nres)=0.0d0 -#endif - -#if defined(PARINT) && defined(MPI) - do i=iint_start,iint_end -#else - do i=2,nres -#endif - dnorm1=dist(i-1,i) - dnorm2=dist(i,i+1) - do j=1,3 - c(j,nres2+2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 & - +(c(j,i+1)-c(j,i))/dnorm2) - enddo - be=0.0D0 - if (i.gt.2) then - if (i.le.nres) phi(i+1)=beta(i-2,i-1,i,i+1) - if ((itype(i).ne.10).and.(itype(i-1).ne.10)) then - tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) - endif - if (itype(i-1).ne.10) then - tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) - omicron(1,i)=alpha(i-2,i-1,i-1+nres) - omicron(2,i)=alpha(i-1+nres,i-1,i) - endif - if (itype(i).ne.10) then - tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) - endif - endif - omeg(i)=beta(nres+i,i,nres2+2,i+1) - alph(i)=alpha(nres+i,i,nres2+2) - theta(i+1)=alpha(i-1,i,i+1) - vbld(i)=dist(i-1,i) - vbld_inv(i)=1.0d0/vbld(i) - vbld(nres+i)=dist(nres+i,i) - if (itype(i).ne.10) then - vbld_inv(nres+i)=1.0d0/vbld(nres+i) - else - vbld_inv(nres+i)=0.0d0 - endif - enddo -#if defined(PARINT) && defined(MPI) - if (nfgtasks1.gt.1) then -!d write(iout,*) "iint_start",iint_start," iint_count", -!d & (iint_count(i),i=0,nfgtasks-1)," iint_displ", -!d & (iint_displ(i),i=0,nfgtasks-1) -!d write (iout,*) "Gather vbld backbone" -!d call flush(iout) - time00=MPI_Wtime() - call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -!d write (iout,*) "Gather vbld_inv" -!d call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -!d write (iout,*) "Gather vbld side chain" -!d call flush(iout) - call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -!d write (iout,*) "Gather vbld_inv side chain" -!d call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start+nres),& - iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1),& - iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -!d write (iout,*) "Gather theta" -!d call flush(iout) - call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -!d write (iout,*) "Gather phi" -!d call flush(iout) - call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#ifdef CRYST_SC -!d write (iout,*) "Gather alph" -!d call flush(iout) - call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -!d write (iout,*) "Gather omeg" -!d call flush(iout) - call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1),& - MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0),& - MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#endif - time_gather=time_gather+MPI_Wtime()-time00 - endif -#endif - do i=1,nres-1 - do j=1,3 -!#ifdef WHAM_RUN -#if defined(WHAM_RUN) || defined(CLUSTER) - dc(j,i)=c(j,i+1)-c(j,i) -#endif - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 -!#ifdef WHAM_RUN -#if defined(WHAM_RUN) || defined(CLUSTER) - dc(j,i+nres)=c(j,i+nres)-c(j,i) -#endif - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - enddo - if (lprn) then - do i=2,nres - write (iout,1212) restyp(itype(i)),i,vbld(i),& - rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),& - rad2deg*alph(i),rad2deg*omeg(i) - enddo - endif - 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) -#ifdef TIMING - time_intfcart=time_intfcart+MPI_Wtime()-time01 -#endif - return - end subroutine int_from_cart1 -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- -! check_sc_distr.f -!----------------------------------------------------------------------------- - subroutine check_sc_distr -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.TIME1' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' - logical :: fail - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - real(kind=8) :: hrtime,mintime,sectime - integer,parameter :: MaxSample=10000000 - real(kind=8),parameter :: delt=1.0D0/MaxSample - real(kind=8),dimension(0:72,0:90) :: prob -!el local variables - integer :: it,i,j,isample,indal,indom - real(kind=8) :: al,om,dV - dV=2.0D0*5.0D0*deg2rad*deg2rad - print *,'dv=',dv - do 10 it=1,1 - if (it.eq.10) goto 10 - open (20,file=restyp(it)//'_distr.sdc',status='unknown') - call gen_side(it,90.0D0 * deg2rad,al,om,fail) - close (20) - goto 10 - open (20,file=restyp(it)//'_distr1.sdc',status='unknown') - do i=0,90 - do j=0,72 - prob(j,i)=0.0D0 - enddo - enddo - do isample=1,MaxSample - call gen_side(it,90.0D0 * deg2rad,al,om,fail) - indal=rad2deg*al/2 - indom=(rad2deg*om+180.0D0)/5 - prob(indom,indal)=prob(indom,indal)+delt - enddo - do i=45,90 - do j=0,72 - write (20,'(2f10.3,1pd15.5)') 2*i+0.0D0,5*j-180.0D0,& - prob(j,i)/dV - enddo - enddo - 10 continue - return - end subroutine check_sc_distr -#endif -!----------------------------------------------------------------------------- -! convert.f -!----------------------------------------------------------------------------- - subroutine geom_to_var(n,x) -! -! Transfer the geometry parameters to the variable array. -! The positions of variables are as follows: -! 1. Virtual-bond torsional angles: 1 thru nres-3 -! 2. Virtual-bond valence angles: nres-2 thru 2*nres-5 -! 3. The polar angles alpha of local SC orientation: 2*nres-4 thru -! 2*nres-4+nside -! 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 -! thru 2*nre-4+2*nside -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' - integer :: n,i - real(kind=8),dimension(n) :: x -!d print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar - do i=4,nres - x(i-3)=phi(i) -!d print *,i,i-3,phi(i) - enddo - if (n.eq.nphi) return - do i=3,nres - x(i-2+nphi)=theta(i) -!d print *,i,i-2+nphi,theta(i) - enddo - if (n.eq.nphi+ntheta) return - do i=2,nres-1 - if (ialph(i,1).gt.0) then - x(ialph(i,1))=alph(i) - x(ialph(i,1)+nside)=omeg(i) -!d print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i) - endif - enddo - return - end subroutine geom_to_var -!----------------------------------------------------------------------------- - subroutine var_to_geom(n,x) -! -! Update geometry parameters according to the variable array. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.IOUNITS' - integer :: n,i,ii - real(kind=8),dimension(n) :: x - logical :: change !,reduce -!el alph=0.0d0 -!el omeg=0.0d0 -!el phi=0.0d0 -!el theta=0.0d0 - - change=reduce(x) - if (n.gt.nphi+ntheta) then - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) -!elwrite(iout,*) "alph",ii,alph -!elwrite(iout,*) "omeg",ii,omeg - enddo - endif - do i=4,nres - phi(i)=x(i-3) -!elwrite(iout,*) "phi",i,phi - enddo - if (n.eq.nphi) return - do i=3,nres - theta(i)=x(i-2+nphi) -!elwrite(iout,*) "theta",i,theta - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end subroutine var_to_geom -!----------------------------------------------------------------------------- - logical function convert_side(alphi,omegi) -! implicit none - real(kind=8) :: alphi,omegi -!el real(kind=8) :: pinorm -! include 'COMMON.GEO' - convert_side=.false. -! Apply periodicity restrictions. - if (alphi.gt.pi) then - alphi=dwapi-alphi - omegi=pinorm(omegi+pi) - convert_side=.true. - endif - return - end function convert_side -!----------------------------------------------------------------------------- - logical function reduce(x) -! -! Apply periodic restrictions to variables. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - logical :: zm,zmiana !,convert_side - real(kind=8),dimension(nvar) :: x - integer :: i,ii,iii - zmiana=.false. - do i=4,nres - x(i-3)=pinorm(x(i-3)) - enddo - if (nvar.gt.nphi+ntheta) then - do i=1,nside - ii=nphi+ntheta+i - iii=ii+nside - x(ii)=thetnorm(x(ii)) - x(iii)=pinorm(x(iii)) -! Apply periodic restrictions. - zm=convert_side(x(ii),x(iii)) - zmiana=zmiana.or.zm - enddo - endif - if (nvar.eq.nphi) return - do i=3,nres - ii=i-2+nphi - iii=i-3 - x(ii)=dmod(x(ii),dwapi) -! Apply periodic restrictions. - if (x(ii).gt.pi) then - zmiana=.true. - x(ii)=dwapi-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.-pi) then - zmiana=.true. - x(ii)=dwapi+x(ii) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-pi-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.0.0d0) then - zmiana=.true. - x(ii)=-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - endif - enddo - reduce=zmiana - return - end function reduce -!----------------------------------------------------------------------------- - real(kind=8) function thetnorm(x) -! This function puts x within [0,2Pi]. - implicit none - real(kind=8) :: x,xx -! include 'COMMON.GEO' - xx=dmod(x,dwapi) - if (xx.lt.0.0d0) xx=xx+dwapi - if (xx.gt.0.9999d0*pi) xx=0.9999d0*pi - thetnorm=xx - return - end function thetnorm -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- - subroutine var_to_geom_restr(n,xx) -! -! Update geometry parameters according to the variable array. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.IOUNITS' - integer :: n,i,ii - real(kind=8),dimension(6*nres) :: x,xx !(maxvar) (maxvar=6*maxres) - logical :: change !,reduce - - call xx2x(x,xx) - change=reduce(x) - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - do i=4,nres - phi(i)=x(i-3) - enddo - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end subroutine var_to_geom_restr -!----------------------------------------------------------------------------- -! gen_rand_conf.F -!----------------------------------------------------------------------------- - subroutine gen_rand_conf(nstart,*) -! Generate random conformation or chain cut and regrowth. - use mcm_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.MCM' -! include 'COMMON.GEO' -! include 'COMMON.CONTROL' - logical :: back,fail !overlap, -!el local variables - integer :: i,nstart,maxsi,nsi,maxnit,nit,niter - integer :: it1,it2,it,j -!d print *,' CG Processor',me,' maxgen=',maxgen - maxsi=100 -!d write (iout,*) 'Gen_Rand_conf: nstart=',nstart - if (nstart.lt.5) then - it1=iabs(itype(2)) - phi(4)=gen_phi(4,iabs(itype(2)),iabs(itype(3))) -! write(iout,*)'phi(4)=',rad2deg*phi(4) - if (nstart.lt.3) theta(3)=gen_theta(iabs(itype(2)),pi,phi(4)) -! write(iout,*)'theta(3)=',rad2deg*theta(3) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(3),alph(2),omeg(2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return 1 - endif ! it1.ne.10 - call orig_frame - i=4 - nstart=4 - else - i=nstart - nstart=max0(i,4) - endif - - maxnit=0 - - nit=0 - niter=0 - back=.false. - do while (i.le.nres .and. niter.lt.maxgen) - if (i.lt.nstart) then - if(iprint.gt.1) then - write (iout,'(/80(1h*)/2a/80(1h*))') & - 'Generation procedure went down to ',& - 'chain beginning. Cannot continue...' - write (*,'(/80(1h*)/2a/80(1h*))') & - 'Generation procedure went down to ',& - 'chain beginning. Cannot continue...' - endif - return 1 - endif - it1=iabs(itype(i-1)) - it2=iabs(itype(i-2)) - it=iabs(itype(i)) -! print *,'Gen_Rand_Conf: i=',i,' it=',it,' it1=',it1,' it2=',it2, -! & ' nit=',nit,' niter=',niter,' maxgen=',maxgen - phi(i+1)=gen_phi(i+1,it1,it) - if (back) then - phi(i)=gen_phi(i+1,it2,it1) -! print *,'phi(',i,')=',phi(i) - theta(i-1)=gen_theta(it2,phi(i-1),phi(i)) - if (it2.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return 1 - endif - call locate_next_res(i-1) - endif - theta(i)=gen_theta(it1,phi(i),phi(i+1)) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return 1 - endif - call locate_next_res(i) - if (overlap(i-1)) then - if (nit.lt.maxnit) then - back=.true. - nit=nit+1 - else - nit=0 - if (i.gt.3) then - back=.true. - i=i-1 - else - write (iout,'(a)') & - 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - write (*,'(a)') & - 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - return 1 - endif - endif - else - back=.false. - nit=0 - i=i+1 - endif - niter=niter+1 - enddo - if (niter.ge.maxgen) then - write (iout,'(a,2i5)') & - 'Too many trials in conformation generation',niter,maxgen - write (*,'(a,2i5)') & - 'Too many trials in conformation generation',niter,maxgen - return 1 - endif - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo - return - end subroutine gen_rand_conf -!----------------------------------------------------------------------------- - logical function overlap(i) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' - integer :: i,j,iti,itj,iteli,itelj,k - real(kind=8) :: redfac,rcomp - integer :: nres2 - nres2=2*nres - data redfac /0.5D0/ - overlap=.false. - iti=iabs(itype(i)) - if (iti.gt.ntyp) return -! Check for SC-SC overlaps. -!d print *,'nnt=',nnt,' nct=',nct - do j=nnt,i-1 - itj=iabs(itype(j)) - if (j.lt.i-1 .or. ipot.ne.4) then - rcomp=sigmaii(iti,itj) - else - rcomp=sigma(iti,itj) - endif -!d print *,'j=',j - if (dist(nres+i,nres+j).lt.redfac*rcomp) then - overlap=.true. -! print *,'overlap, SC-SC: i=',i,' j=',j, -! & ' dist=',dist(nres+i,nres+j),' rcomp=', -! & rcomp - return - endif - enddo -! Check for overlaps between the added peptide group and the preceding -! SCs. - iteli=itel(i) - do j=1,3 -! c(j,nres2+1)=0.5D0*(c(j,i)+c(j,i+1)) - c(j,nres2+3)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itj=iabs(itype(j)) -!d print *,'overlap, p-Sc: i=',i,' j=',j, -!d & ' dist=',dist(nres+j,maxres2+1) - if (dist(nres+j,nres2+3).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -! Check for overlaps between the added side chain and the preceding peptide -! groups. - do j=1,nnt-2 - do k=1,3 - c(k,nres2+3)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -!d print *,'overlap, SC-p: i=',i,' j=',j, -!d & ' dist=',dist(nres+i,maxres2+1) - if (dist(nres+i,nres2+3).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -! Check for p-p overlaps - do j=1,3 - c(j,nres2+4)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itelj=itel(j) - do k=1,3 - c(k,nres2+4)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -!d print *,'overlap, p-p: i=',i,' j=',j, -!d & ' dist=',dist(maxres2+1,maxres2+2) - if(iteli.ne.0.and.itelj.ne.0)then - if (dist(nres2+3,nres2+4).lt.rpp(iteli,itelj)*redfac) then - overlap=.true. - return - endif - endif - enddo - return - end function overlap -!----------------------------------------------------------------------------- - real(kind=8) function gen_phi(i,it1,it2) - use random, only:ran_number -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.BOUNDS' - integer :: i,it1,it2 -! gen_phi=ran_number(-pi,pi) -! 8/13/98 Generate phi using pre-defined boundaries - gen_phi=ran_number(phibound(1,i),phibound(2,i)) - return - end function gen_phi -!----------------------------------------------------------------------------- - real(kind=8) function gen_theta(it,gama,gama1) - use random,only:binorm -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.GEO' - real(kind=8),dimension(2) :: y,z - real(kind=8) :: theta_max,theta_min,sig,ak -!el local variables - integer :: j,it,k - real(kind=8) :: gama,gama1,thet_pred_mean,theta_temp -! print *,'gen_theta: it=',it - theta_min=0.05D0*pi - theta_max=0.95D0*pi - if (dabs(gama).gt.dwapi) then - y(1)=dcos(gama) - y(2)=dsin(gama) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (dabs(gama1).gt.dwapi) then - z(1)=dcos(gama1) - z(2)=dsin(gama1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif - thet_pred_mean=a0thet(it) - do k=1,2 - thet_pred_mean=thet_pred_mean+athet(k,it,1,1)*y(k) & - +bthet(k,it,1,1)*z(k) - enddo - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo - sig=0.5D0/(sig*sig+sigc0(it)) - ak=dexp(gthet(1,it)- & - 0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2) -! print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3) -! print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak - theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak) - if (theta_temp.lt.theta_min) theta_temp=theta_min - if (theta_temp.gt.theta_max) theta_temp=theta_max - gen_theta=theta_temp -! print '(a)','Exiting GENTHETA.' - return - end function gen_theta -!----------------------------------------------------------------------------- - subroutine gen_side(it,the,al,om,fail) - use random, only:ran_number,mult_norm1 -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' - real(kind=8) :: MaxBoxLen=10.0D0 - real(kind=8),dimension(3,3) :: Ap_inv,a,vec - real(kind=8),dimension(:,:),allocatable :: z !(3,maxlob) - real(kind=8),dimension(:),allocatable :: W1,detAp !(maxlob) - real(kind=8),dimension(:),allocatable :: sumW !(0:maxlob) - real(kind=8),dimension(2) :: y,cm,eig - real(kind=8),dimension(2,2) :: box - real(kind=8),dimension(100) :: work - real(kind=8) :: eig_limit=1.0D-8 - real(kind=8) :: Big=10.0D0 - logical :: lprint,fail,lcheck -!el local variables - integer :: it,i,j,k,l,nlobit,ial,iom,iii,ilob - real(kind=8) :: the,al,om,detApi,wart,y2,wykl,radmax - real(kind=8) :: tant,zz1,W1i,radius,zk,fac,dV,sum,sum1 - real(kind=8) :: which_lobe - lcheck=.false. - lprint=.false. - fail=.false. - if (the.eq.0.0D0 .or. the.eq.pi) then -#ifdef MPI - write (*,'(a,i4,a,i3,a,1pe14.5)') & - 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the -#else -!d write (iout,'(a,i3,a,1pe14.5)') -!d & 'Error in GenSide: it=',it,' theta=',the -#endif - fail=.true. - return - endif - tant=dtan(the-pipol) - nlobit=nlob(it) - allocate(z(3,nlobit)) - allocate(W1(nlobit)) - allocate(detAp(nlobit)) - allocate(sumW(0:nlobit)) - if (lprint) then -#ifdef MPI - print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.' - write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.' -#endif - print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant - write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the,& - ' tant=',tant - endif - do i=1,nlobit - zz1=tant-censc(1,i,it) - do k=1,3 - do l=1,3 - a(k,l)=gaussc(k,l,i,it) - enddo - enddo - detApi=a(2,2)*a(3,3)-a(2,3)**2 - Ap_inv(2,2)=a(3,3)/detApi - Ap_inv(2,3)=-a(2,3)/detApi - Ap_inv(3,2)=Ap_inv(2,3) - Ap_inv(3,3)=a(2,2)/detApi - if (lprint) then - write (*,'(/a,i2/)') 'Cluster #',i - write (*,'(3(1pe14.5),5x,1pe14.5)') & - ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - write (iout,'(/a,i2/)') 'Cluster #',i - write (iout,'(3(1pe14.5),5x,1pe14.5)') & - ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - endif - W1i=0.0D0 - do k=2,3 - do l=2,3 - W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l) - enddo - enddo - W1i=a(1,1)-W1i - W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1) -! if (lprint) write(*,'(a,3(1pe15.5)/)') -! & 'detAp, W1, anormi',detApi,W1i,anormi - do k=2,3 - zk=censc(k,i,it) - do l=2,3 - zk=zk+zz1*Ap_inv(k,l)*a(l,1) - enddo - z(k,i)=zk - enddo - detAp(i)=dsqrt(detApi) - enddo - - if (lprint) then - print *,'W1:',(w1(i),i=1,nlobit) - print *,'detAp:',(detAp(i),i=1,nlobit) - print *,'Z' - do i=1,nlobit - print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3) - enddo - write (iout,*) 'W1:',(w1(i),i=1,nlobit) - write (iout,*) 'detAp:',(detAp(i),i=1,nlobit) - write (iout,*) 'Z' - do i=1,nlobit - write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3) - enddo - endif - if (lcheck) then -! Writing the distribution just to check the procedure - fac=0.0D0 - dV=deg2rad**2*10.0D0 - sum=0.0D0 - sum1=0.0D0 - do i=1,nlobit - fac=fac+W1(i)/detAp(i) - enddo - fac=1.0D0/(2.0D0*fac*pi) -!d print *,it,'fac=',fac - do ial=90,180,2 - y(1)=deg2rad*ial - do iom=-180,180,5 - y(2)=deg2rad*iom - wart=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo - y2=y(2) - - do iii=-1,1 - - y(2)=y2+iii*dwapi - - wykl=0.0D0 - do j=1,2 - do k=1,2 - wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i)) - enddo - enddo - wart=wart+W1(i)*dexp(-0.5D0*wykl) - - enddo - - y(2)=y2 - - enddo -! print *,'y',y(1),y(2),' fac=',fac - wart=fac*wart - write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart - sum=sum+wart - sum1=sum1+1.0D0 - enddo - enddo -! print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV - return - endif - -! Calculate the CM of the system -! - do i=1,nlobit - W1(i)=W1(i)/detAp(i) - enddo - sumW(0)=0.0D0 - do i=1,nlobit - sumW(i)=sumW(i-1)+W1(i) - enddo - cm(1)=z(2,1)*W1(1) - cm(2)=z(3,1)*W1(1) - do j=2,nlobit - cm(1)=cm(1)+z(2,j)*W1(j) - cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1))) - enddo - cm(1)=cm(1)/sumW(nlobit) - cm(2)=cm(2)/sumW(nlobit) - if (cm(1).gt.Big .or. cm(1).lt.-Big .or. & - cm(2).gt.Big .or. cm(2).lt.-Big) then -!d write (iout,'(a)') -!d & 'Unexpected error in GenSide - CM coordinates too large.' -!d write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2) -!d write (*,'(a)') -!d & 'Unexpected error in GenSide - CM coordinates too large.' -!d write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2) - fail=.true. - return - endif -!d print *,'CM:',cm(1),cm(2) -! -! Find the largest search distance from CM -! - radmax=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo -#ifdef NAG - call f02faf('N','U',2,a,3,eig,work,100,ifail) -#else - call djacob(2,3,10000,1.0d-10,a,vec,eig) -#endif -#ifdef MPI - if (lprint) then - print *,'*************** CG Processor',me - print *,'CM:',cm(1),cm(2) - write (iout,*) '*************** CG Processor',me - write (iout,*) 'CM:',cm(1),cm(2) - print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - write (iout,'(A,8f10.5)') & - 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - endif -#endif - if (eig(1).lt.eig_limit) then - write(iout,'(a)') & - 'From Mult_Norm: Eigenvalues of A are too small.' - write(*,'(a)') & - 'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif - radius=0.0D0 -!d print *,'i=',i - do j=1,2 - radius=radius+pinorm(z(j+1,i)-cm(j))**2 - enddo - radius=dsqrt(radius)+3.0D0/dsqrt(eig(1)) - if (radius.gt.radmax) radmax=radius - enddo - if (radmax.gt.pi) radmax=pi -! -! Determine the boundaries of the search rectangle. -! - if (lprint) then - print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) ) - print '(a,4(1pe14.4))','radmax: ',radmax - endif - box(1,1)=dmax1(cm(1)-radmax,0.0D0) - box(2,1)=dmin1(cm(1)+radmax,pi) - box(1,2)=cm(2)-radmax - box(2,2)=cm(2)+radmax - if (lprint) then -#ifdef MPI - print *,'CG Processor',me,' Array BOX:' -#else - print *,'Array BOX:' -#endif - print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2) - print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) ) -#ifdef MPI - write (iout,*)'CG Processor',me,' Array BOX:' -#else - write (iout,*)'Array BOX:' -#endif - write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2) - write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) ) - endif - if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then -#ifdef MPI - write (iout,'(a,i4,a,3e15.5)') 'CG Processor:',me,': bad sampling box.',box(1,2),box(2,2),radmax - write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' -#else -! write (iout,'(a)') 'Bad sampling box.' -#endif - fail=.true. - return - endif - which_lobe=ran_number(0.0D0,sumW(nlobit)) -! print '(a,1pe14.4)','which_lobe=',which_lobe - do i=1,nlobit - if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1 - enddo - 1 ilob=i -! print *,'ilob=',ilob,' nlob=',nlob(it) - do i=2,3 - cm(i-1)=z(i,ilob) - do j=2,3 - a(i-1,j-1)=gaussc(i,j,ilob,it) - enddo - enddo -!d print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.' - call mult_norm1(3,2,a,cm,box,y,fail) - if (fail) return - al=y(1) - om=pinorm(y(2)) -!d print *,'al=',al,' om=',om -!d stop - return - end subroutine gen_side -!----------------------------------------------------------------------------- - subroutine overlap_sc(scfail) -! -! Internal and cartesian coordinates must be consistent as input, -! and will be up-to-date on return. -! At the end of this procedure, scfail is true if there are -! overlapping residues left, or false otherwise (success) -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.VAR' -! include 'COMMON.SBRIDGE' -! include 'COMMON.IOUNITS' - logical :: had_overlaps,fail,scfail - integer,dimension(nres) :: ioverlap !(maxres) - integer :: ioverlap_last,k,maxsi,i,iti,nsi - integer :: ires,j - - had_overlaps=.false. - call overlap_sc_list(ioverlap,ioverlap_last) - if (ioverlap_last.gt.0) then - write (iout,*) '#OVERLAPing residues ',ioverlap_last - write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last) - had_overlaps=.true. - endif - - maxsi=1000 - do k=1,1000 - if (ioverlap_last.eq.0) exit - - do ires=1,ioverlap_last - i=ioverlap(ires) - iti=iabs(itype(i)) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) goto 999 - endif - enddo - - call chainbuild - call overlap_sc_list(ioverlap,ioverlap_last) -! write (iout,*) 'Overlaping residues ',ioverlap_last, -! & (ioverlap(j),j=1,ioverlap_last) - enddo - - if (k.le.1000.and.ioverlap_last.eq.0) then - scfail=.false. - if (had_overlaps) then - write (iout,*) '#OVERLAPing all corrected after ',k,& - ' random generation' - endif - else - scfail=.true. - write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last - write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last) - endif - - return - - 999 continue - write (iout,'(a30,i5,a12,i4)') & - '#OVERLAP FAIL in gen_side after',maxsi,& - 'iter for RES',i - scfail=.true. - return - end subroutine overlap_sc -!----------------------------------------------------------------------------- - subroutine overlap_sc_list(ioverlap,ioverlap_last) - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.VAR' -! include 'COMMON.CALC' - logical :: fail - integer,dimension(nres) :: ioverlap !(maxres) - integer :: ioverlap_last -!el local variables - integer :: ind,iint - real(kind=8) :: redfac,sig !rrij,sigsq, - integer :: itypi,itypj,itypi1 - real(kind=8) :: xi,yi,zi,sig0ij,rcomp,rrij,rij_shift - data redfac /0.5D0/ - - ioverlap_last=0 -! Check for SC-SC overlaps and mark residues -! print *,'>>overlap_sc nnt=',nnt,' nct=',nct - ind=0 - do i=iatsc_s,iatsc_e - itypi=iabs(itype(i)) - itypi1=iabs(itype(i+1)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=iabs(itype(j)) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - if (j.gt.i+1) then - rcomp=sigmaii(itypi,itypj) - else - rcomp=sigma(itypi,itypj) - endif -! print '(2(a3,2i3),a3,2f10.5)', -! & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j) -! & ,rcomp - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij - -!t if ( 1.0/rij .lt. redfac*rcomp .or. -!t & rij_shift.le.0.0D0 ) then - if ( rij_shift.le.0.0D0 ) then -!d write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') -!d & 'overlap SC-SC: i=',i,' j=',j, -!d & ' dist=',dist(nres+i,nres+j),' rcomp=', -!d & rcomp,1.0/rij,rij_shift - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=i - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1 - enddo - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=j - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1 - enddo - endif - enddo - enddo - enddo - return - end subroutine overlap_sc_list -#endif -!----------------------------------------------------------------------------- -! energy_p_new_barrier.F -!----------------------------------------------------------------------------- - subroutine sc_angular -! Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, -! om12. Called by ebp, egb, and egbv. - use calc_data -! implicit none -! include 'COMMON.CALC' -! include 'COMMON.IOUNITS' - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - chiom12=chi12*om12 -! Calculate eps1(om12) and its derivative in om12 - faceps1=1.0D0-om12*chiom12 - faceps1_inv=1.0D0/faceps1 - eps1=dsqrt(faceps1_inv) -! Following variable is eps1*deps1/dom12 - eps1_om12=faceps1_inv*chiom12 -! diagnostics only -! faceps1_inv=om12 -! eps1=om12 -! eps1_om12=1.0d0 -! write (iout,*) "om12",om12," eps1",eps1 -! Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, -! and om12. - om1om2=om1*om2 - chiom1=chi1*om1 - chiom2=chi2*om2 - facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 - sigsq=1.0D0-facsig*faceps1_inv - sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv - sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv - sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 -! diagnostics only -! sigsq=1.0d0 -! sigsq_om1=0.0d0 -! sigsq_om2=0.0d0 -! sigsq_om12=0.0d0 -! write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 -! write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, -! & " eps1",eps1 -! Calculate eps2 and its derivatives in om1, om2, and om12. - chipom1=chip1*om1 - chipom2=chip2*om2 - chipom12=chip12*om12 - facp=1.0D0-om12*chipom12 - facp_inv=1.0D0/facp - facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 -! write (iout,*) "chipom1",chipom1," chipom2",chipom2, -! & " chipom12",chipom12," facp",facp," facp_inv",facp_inv -! Following variable is the square root of eps2 - eps2rt=1.0D0-facp1*facp_inv -! Following three variables are the derivatives of the square root of eps -! in om1, om2, and om12. - eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv - eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv - eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 -! Evaluate the "asymmetric" factor in the VDW constant, eps3 - eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 -! write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt -! write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, -! & " eps2rt_om12",eps2rt_om12 -! Calculate whole angle-dependent part of epsilon and contributions -! to its derivatives - return - end subroutine sc_angular -!----------------------------------------------------------------------------- -! initialize_p.F -!----------------------------------------------------------------------------- - subroutine int_bounds(total_ints,lower_bound,upper_bound) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.SETUP' - integer :: total_ints,lower_bound,upper_bound,nint - integer,dimension(0:nfgtasks) :: int4proc,sint4proc !(0:max_fg_procs) - integer :: i,nexcess - nint=total_ints/nfgtasks - do i=1,nfgtasks - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks - do i=1,nexcess - int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank) - lower_bound=lower_bound+1 - return - end subroutine int_bounds -!----------------------------------------------------------------------------- - subroutine int_bounds1(total_ints,lower_bound,upper_bound) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.SETUP' - integer :: total_ints,lower_bound,upper_bound,nint - integer :: nexcess,i - integer,dimension(0:nfgtasks) :: int4proc,sint4proc !(0:max_fg_procs) - nint=total_ints/nfgtasks1 - do i=1,nfgtasks1 - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks1 - do i=1,nexcess - int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank1-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank1) - lower_bound=lower_bound+1 - return - end subroutine int_bounds1 -!----------------------------------------------------------------------------- -! intcartderiv.F -!----------------------------------------------------------------------------- - subroutine chainbuild_cart -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use control_data -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.TIME1' -! include 'COMMON.IOUNITS' - integer :: j,i,ierror,ierr - real(kind=8) :: time00,time01 -#ifdef MPI - if (nfgtasks.gt.1) then -! write (iout,*) "BCAST in chainbuild_cart" -! call flush(iout) -! Broadcast the order to build the chain and compute internal coordinates -! to the slaves. The slaves receive the order in ERGASTULUM. - time00=MPI_Wtime() -! write (iout,*) "CHAINBUILD_CART: DC before BCAST" -! do i=0,nres -! write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -! & (dc(j,i+nres),j=1,3) -! enddo - if (fg_rank.eq.0) & - call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_bcast7=time_bcast7+MPI_Wtime()-time00 - time01=MPI_Wtime() - call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "CHAINBUILD_CART: DC after BCAST" -! do i=0,nres -! write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -! & (dc(j,i+nres),j=1,3) -! enddo -! write (iout,*) "End BCAST in chainbuild_cart" -! call flush(iout) - time_bcast=time_bcast+MPI_Wtime()-time00 - time_bcastc=time_bcastc+MPI_Wtime()-time01 - endif -#endif - do j=1,3 - c(j,1)=dc(j,0) - enddo - do i=2,nres - do j=1,3 - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo - enddo - do i=1,nres - do j=1,3 - c(j,i+nres)=c(j,i)+dc(j,i+nres) - enddo - enddo -! write (iout,*) "CHAINBUILD_CART" -! call cartprint - call int_from_cart1(.false.) - return - end subroutine chainbuild_cart -!----------------------------------------------------------------------------- -! intcor.f -!----------------------------------------------------------------------------- - real(kind=8) function alpha(i1,i2,i3) -! -! Calculates the planar angle between atoms (i1), (i2), and (i3). -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -!el local variables - integer :: i1,i2,i3 - real(kind=8) :: x12,x23,y12,y23,z12,z23,vnorm,wnorm,scalar - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - vnorm=dsqrt(x12*x12+y12*y12+z12*z12) - wnorm=dsqrt(x23*x23+y23*y23+z23*z23) - scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) - alpha=arcos(scalar) - return - end function alpha -!----------------------------------------------------------------------------- - real(kind=8) function beta(i1,i2,i3,i4) -! -! Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -!el local variables - integer :: i1,i2,i3,i4 - real(kind=8) :: x12,x23,x34,y12,y23,y34,z12,z23,z34 - real(kind=8) :: wx,wy,wz,wnorm,vx,vy,vz,vnorm,scalar,angle - real(kind=8) :: tx,ty,tz - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - x34=c(1,i4)-c(1,i3) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - y34=c(2,i4)-c(2,i3) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - z34=c(3,i4)-c(3,i3) -!d print '(2i3,3f10.5)',i1,i2,x12,y12,z12 -!d print '(2i3,3f10.5)',i2,i3,x23,y23,z23 -!d print '(2i3,3f10.5)',i3,i4,x34,y34,z34 - wx=-y23*z34+y34*z23 - wy=x23*z34-z23*x34 - wz=-x23*y34+y23*x34 - wnorm=dsqrt(wx*wx+wy*wy+wz*wz) - vx=y12*z23-z12*y23 - vy=-x12*z23+z12*x23 - vz=x12*y23-y12*x23 - vnorm=dsqrt(vx*vx+vy*vy+vz*vz) - if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then - scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) - if (dabs(scalar).gt.1.0D0) & - scalar=0.99999999999999D0*scalar/dabs(scalar) - angle=dacos(scalar) -!d print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, -!d &scalar,angle - else - angle=pi - endif -! if (angle.le.0.0D0) angle=pi+angle - tx=vy*wz-vz*wy - ty=-vx*wz+vz*wx - tz=vx*wy-vy*wx - scalar=tx*x23+ty*y23+tz*z23 - if (scalar.lt.0.0D0) angle=-angle - beta=angle - return - end function beta -!----------------------------------------------------------------------------- - real(kind=8) function dist(i1,i2) -! -! Calculates the distance between atoms (i1) and (i2). -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -!el local variables - integer :: i1,i2 - real(kind=8) :: x12,y12,z12 - x12=c(1,i1)-c(1,i2) - y12=c(2,i1)-c(2,i2) - z12=c(3,i1)-c(3,i2) - dist=dsqrt(x12*x12+y12*y12+z12*z12) - return - end function dist -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- -! local_move.f -!----------------------------------------------------------------------------- - subroutine local_move_init(debug) -!rc implicit none - -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' ! Needed by COMMON.LOCAL -! include 'COMMON.GEO' ! For pi, deg2rad -! include 'COMMON.LOCAL' ! For vbl -! include 'COMMON.LOCMOVE' - -! INPUT arguments - logical :: debug - - -! Determine wheter to do some debugging output - locmove_output=debug - -! Set the init_called flag to 1 - init_called=1 - -! The following are never changed - min_theta=60.D0*deg2rad ! (0,PI) - max_theta=175.D0*deg2rad ! (0,PI) - dmin2=vbl*vbl*2.*(1.-cos(min_theta)) - dmax2=vbl*vbl*2.*(1.-cos(max_theta)) - flag=1.0D300 - small=1.0D-5 - small2=0.5*small*small - -! Not really necessary... - a_n=0 - b_n=0 - res_n=0 - - return - end subroutine local_move_init -!----------------------------------------------------------------------------- - subroutine local_move(n_start, n_end, PHImin, PHImax) -! Perform a local move between residues m and n (inclusive) -! PHImin and PHImax [0,PI] determine the size of the move -! Works on whatever structure is in the variables theta and phi, -! sidechain variables are left untouched -! The final structure is NOT minimized, but both the cartesian -! variables c and the angles are up-to-date at the end (no further -! chainbuild is required) -!rc implicit none - use random,only:ran_number -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.MINIM' -! include 'COMMON.SBRIDGE' -! include 'COMMON.LOCMOVE' - -! External functions -!EL integer move_res -!EL external move_res -!EL double precision ran_number -!EL external ran_number - -! INPUT arguments - integer :: n_start, n_end ! First and last residues to move - real(kind=8) :: PHImin, PHImax ! min/max angles [0,PI] - -! Local variables - integer :: i,j - real(kind=8) :: min,max - integer :: iretcode - - -! Check if local_move_init was called. This assumes that it -! would not be 1 if not explicitely initialized - if (init_called.ne.1) then - write(6,*)' *** local_move_init not called!!!' - stop - endif - -! Quick check for crazy range - if (n_start.gt.n_end .or. n_start.lt.1 .or. n_end.gt.nres) then - write(6,'(a,i3,a,i3)') & - ' *** Cannot make local move between n_start = ',& - n_start,' and n_end = ',n_end - return - endif - -! Take care of end residues first... - if (n_start.eq.1) then -! Move residue 1 (completely random) - theta(3)=ran_number(min_theta,max_theta) - phi(4)=ran_number(-PI,PI) - i=2 - else - i=n_start - endif - if (n_end.eq.nres) then -! Move residue nres (completely random) - theta(nres)=ran_number(min_theta,max_theta) - phi(nres)=ran_number(-PI,PI) - j=nres-1 - else - j=n_end - endif - -! ...then go through all other residues one by one -! Start from the two extremes and converge - call chainbuild - do while (i.le.j) - min=PHImin - max=PHImax -!$$$c Move the first two residues by less than the others -!$$$ if (i-n_start.lt.3) then -!$$$ if (i-n_start.eq.0) then -!$$$ min=0.4*PHImin -!$$$ max=0.4*PHImax -!$$$ else if (i-n_start.eq.1) then -!$$$ min=0.8*PHImin -!$$$ max=0.8*PHImax -!$$$ else if (i-n_start.eq.2) then -!$$$ min=PHImin -!$$$ max=PHImax -!$$$ endif -!$$$ endif - -! The actual move, on residue i - iretcode=move_res(min,max,i) ! Discard iretcode - i=i+1 - - if (i.le.j) then - min=PHImin - max=PHImax -!$$$c Move the last two residues by less than the others -!$$$ if (n_end-j.lt.3) then -!$$$ if (n_end-j.eq.0) then -!$$$ min=0.4*PHImin -!$$$ max=0.4*PHImax -!$$$ else if (n_end-j.eq.1) then -!$$$ min=0.8*PHImin -!$$$ max=0.8*PHImax -!$$$ else if (n_end-j.eq.2) then -!$$$ min=PHImin -!$$$ max=PHImax -!$$$ endif -!$$$ endif - -! The actual move, on residue j - iretcode=move_res(min,max,j) ! Discard iretcode - j=j-1 - endif - enddo - - call int_from_cart(.false.,.false.) - - return - end subroutine local_move -!----------------------------------------------------------------------------- - subroutine output_tabs -! Prints out the contents of a_..., b_..., res_... -! implicit none - -! Includes -! include 'COMMON.GEO' -! include 'COMMON.LOCMOVE' - -! Local variables - integer :: i,j - - write(6,*)'a_...' - write(6,'(8f7.1)')(a_ang(i)*rad2deg,i=0,a_n-1) - write(6,'(8(2x,3l1,2x))')((a_tab(i,j),i=0,2),j=0,a_n-1) - - write(6,*)'b_...' - write(6,'(4f7.1)')(b_ang(i)*rad2deg,i=0,b_n-1) - write(6,'(4(2x,3l1,2x))')((b_tab(i,j),i=0,2),j=0,b_n-1) - - write(6,*)'res_...' - write(6,'(12f7.1)')(res_ang(i)*rad2deg,i=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(0,i,j),i=0,2),j=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(1,i,j),i=0,2),j=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(2,i,j),i=0,2),j=0,res_n-1) - - return - end subroutine output_tabs -!----------------------------------------------------------------------------- - subroutine angles2tab(PHImin,PHImax,n,ang,tab) -! Only uses angles if [0,PI] (but PHImin cannot be 0., -! and PHImax cannot be PI) -! implicit none - -! Includes -! include 'COMMON.GEO' - -! INPUT arguments - real(kind=8) :: PHImin,PHImax - -! OUTPUT arguments - integer :: n - real(kind=8),dimension(0:3) :: ang - logical,dimension(0:2,0:3) :: tab - - - if (PHImin .eq. PHImax) then -! Special case with two 010's - n = 2; - ang(0) = -PHImin; - ang(1) = PHImin; - tab(0,0) = .false. - tab(2,0) = .false. - tab(0,1) = .false. - tab(2,1) = .false. - tab(1,0) = .true. - tab(1,1) = .true. - else if (PHImin .eq. PI) then -! Special case with one 010 - n = 1 - ang(0) = PI - tab(0,0) = .false. - tab(2,0) = .false. - tab(1,0) = .true. - else if (PHImax .eq. 0.) then -! Special case with one 010 - n = 1 - ang(0) = 0. - tab(0,0) = .false. - tab(2,0) = .false. - tab(1,0) = .true. - else -! Standard cases - n = 0 - if (PHImin .gt. 0.) then -! Start of range (011) - ang(n) = PHImin - tab(0,n) = .false. - tab(1,n) = .true. - tab(2,n) = .true. -! End of range (110) - ang(n+1) = -PHImin - tab(0,n+1) = .true. - tab(1,n+1) = .true. - tab(2,n+1) = .false. - n = n+2 - endif - if (PHImax .lt. PI) then -! Start of range (011) - ang(n) = -PHImax - tab(0,n) = .false. - tab(1,n) = .true. - tab(2,n) = .true. -! End of range (110) - ang(n+1) = PHImax - tab(0,n+1) = .true. - tab(1,n+1) = .true. - tab(2,n+1) = .false. - n = n+2 - endif - endif - - return - end subroutine angles2tab -!----------------------------------------------------------------------------- - subroutine minmax_angles(x,y,z,r,n,ang,tab) -! When solutions do not exist, assume all angles -! are acceptable - i.e., initial geometry must be correct -! implicit none - -! Includes -! include 'COMMON.GEO' -! include 'COMMON.LOCMOVE' - -! Input arguments - real(kind=8) :: x,y,z,r - -! Output arguments - integer :: n - real(kind=8),dimension(0:3) :: ang - logical,dimension(0:2,0:3) :: tab - -! Local variables - real(kind=8) :: num, denom, phi - real(kind=8) :: Kmin, Kmax - integer :: i - - - num = x*x + y*y + z*z - denom = x*x + y*y - n = 0 - if (denom .gt. 0.) then - phi = atan2(y,x) - denom = 2.*r*sqrt(denom) - num = num+r*r - Kmin = (num - dmin2)/denom - Kmax = (num - dmax2)/denom - -! Allowed values of K (else all angles are acceptable) -! -1 <= Kmin < 1 -! -1 < Kmax <= 1 - if (Kmin .gt. 1. .or. abs(Kmin-1.) .lt. small2) then - Kmin = -flag - else if (Kmin .lt. -1. .or. abs(Kmin+1.) .lt. small2) then - Kmin = PI - else - Kmin = acos(Kmin) - endif - - if (Kmax .lt. -1. .or. abs(Kmax+1.) .lt. small2) then - Kmax = flag - else if (Kmax .gt. 1. .or. abs(Kmax-1.) .lt. small2) then - Kmax = 0. - else - Kmax = acos(Kmax) - endif - - if (Kmax .lt. Kmin) Kmax = Kmin - - call angles2tab(Kmin, Kmax, n, ang, tab) - -! Add phi and check that angles are within range (-PI,PI] - do i=0,n-1 - ang(i) = ang(i)+phi - if (ang(i) .le. -PI) then - ang(i) = ang(i)+2.*PI - else if (ang(i) .gt. PI) then - ang(i) = ang(i)-2.*PI - endif - enddo - endif - - return - end subroutine minmax_angles -!----------------------------------------------------------------------------- - subroutine construct_tab -! Take a_... and b_... values and produces the results res_... -! x_ang are assumed to be all different (diff > small) -! x_tab(1,i) must be 1 for all i (i.e., all x_ang are acceptable) -! implicit none - -! Includes -! include 'COMMON.LOCMOVE' - -! Local variables - integer :: n_max,i,j,index - logical :: done - real(kind=8) :: phi - - - n_max = a_n + b_n - if (n_max .eq. 0) then - res_n = 0 - return - endif - - do i=0,n_max-1 - do j=0,1 - res_tab(j,0,i) = .true. - res_tab(j,2,i) = .true. - res_tab(j,1,i) = .false. - enddo - enddo - - index = 0 - phi = -flag - done = .false. - do while (.not.done) - res_ang(index) = flag - -! Check a first... - do i=0,a_n-1 - if ((a_ang(i)-phi).gt.small .and. & - a_ang(i) .lt. res_ang(index)) then -! Found a lower angle - res_ang(index) = a_ang(i) -! Copy the values from a_tab into res_tab(0,,) - res_tab(0,0,index) = a_tab(0,i) - res_tab(0,1,index) = a_tab(1,i) - res_tab(0,2,index) = a_tab(2,i) -! Set default values for res_tab(1,,) - res_tab(1,0,index) = .true. - res_tab(1,1,index) = .false. - res_tab(1,2,index) = .true. - else if (abs(a_ang(i)-res_ang(index)).lt.small) then -! Found an equal angle (can only be equal to a b_ang) - res_tab(0,0,index) = a_tab(0,i) - res_tab(0,1,index) = a_tab(1,i) - res_tab(0,2,index) = a_tab(2,i) - endif - enddo -! ...then check b - do i=0,b_n-1 - if ((b_ang(i)-phi).gt.small .and. & - b_ang(i) .lt. res_ang(index)) then -! Found a lower angle - res_ang(index) = b_ang(i) -! Copy the values from b_tab into res_tab(1,,) - res_tab(1,0,index) = b_tab(0,i) - res_tab(1,1,index) = b_tab(1,i) - res_tab(1,2,index) = b_tab(2,i) -! Set default values for res_tab(0,,) - res_tab(0,0,index) = .true. - res_tab(0,1,index) = .false. - res_tab(0,2,index) = .true. - else if (abs(b_ang(i)-res_ang(index)).lt.small) then -! Found an equal angle (can only be equal to an a_ang) - res_tab(1,0,index) = b_tab(0,i) - res_tab(1,1,index) = b_tab(1,i) - res_tab(1,2,index) = b_tab(2,i) - endif - enddo - - if (res_ang(index) .eq. flag) then - res_n = index - done = .true. - else if (index .eq. n_max-1) then - res_n = n_max - done = .true. - else - phi = res_ang(index) ! Store previous angle - index = index+1 - endif - enddo - -! Fill the gaps -! First a... - index = 0 - if (a_n .gt. 0) then - do while (.not.res_tab(0,1,index)) - index=index+1 - enddo - done = res_tab(0,2,index) - do i=index+1,res_n-1 - if (res_tab(0,1,i)) then - done = res_tab(0,2,i) - else - res_tab(0,0,i) = done - res_tab(0,1,i) = done - res_tab(0,2,i) = done - endif - enddo - done = res_tab(0,0,index) - do i=index-1,0,-1 - if (res_tab(0,1,i)) then - done = res_tab(0,0,i) - else - res_tab(0,0,i) = done - res_tab(0,1,i) = done - res_tab(0,2,i) = done - endif - enddo - else - do i=0,res_n-1 - res_tab(0,0,i) = .true. - res_tab(0,1,i) = .true. - res_tab(0,2,i) = .true. - enddo - endif -! ...then b - index = 0 - if (b_n .gt. 0) then - do while (.not.res_tab(1,1,index)) - index=index+1 - enddo - done = res_tab(1,2,index) - do i=index+1,res_n-1 - if (res_tab(1,1,i)) then - done = res_tab(1,2,i) - else - res_tab(1,0,i) = done - res_tab(1,1,i) = done - res_tab(1,2,i) = done - endif - enddo - done = res_tab(1,0,index) - do i=index-1,0,-1 - if (res_tab(1,1,i)) then - done = res_tab(1,0,i) - else - res_tab(1,0,i) = done - res_tab(1,1,i) = done - res_tab(1,2,i) = done - endif - enddo - else - do i=0,res_n-1 - res_tab(1,0,i) = .true. - res_tab(1,1,i) = .true. - res_tab(1,2,i) = .true. - enddo - endif - -! Finally fill the last row with AND operation - do i=0,res_n-1 - do j=0,2 - res_tab(2,j,i) = (res_tab(0,j,i) .and. res_tab(1,j,i)) - enddo - enddo - - return - end subroutine construct_tab -!----------------------------------------------------------------------------- - subroutine construct_ranges(phi_n,phi_start,phi_end) -! Given the data in res_..., construct a table of -! min/max allowed angles -! implicit none - -! Includes -! include 'COMMON.GEO' -! include 'COMMON.LOCMOVE' - -! Output arguments - integer :: phi_n - real(kind=8),dimension(0:11) :: phi_start,phi_end - -! Local variables - logical :: done - integer :: index - - - if (res_n .eq. 0) then -! Any move is allowed - phi_n = 1 - phi_start(0) = -PI - phi_end(0) = PI - else - phi_n = 0 - index = 0 - done = .false. - do while (.not.done) -! Find start of range (01x) - done = .false. - do while (.not.done) - if (res_tab(2,0,index).or.(.not.res_tab(2,1,index))) then - index=index+1 - else - done = .true. - phi_start(phi_n) = res_ang(index) - endif - if (index .eq. res_n) done = .true. - enddo -! If a start was found (index < res_n), find the end of range (x10) -! It may not be found without wrapping around - if (index .lt. res_n) then - done = .false. - do while (.not.done) - if ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) then - index=index+1 - else - done = .true. - endif - if (index .eq. res_n) done = .true. - enddo - if (index .lt. res_n) then -! Found the end of the range - phi_end(phi_n) = res_ang(index) - phi_n=phi_n+1 - index=index+1 - if (index .eq. res_n) then - done = .true. - else - done = .false. - endif - else -! Need to wrap around - done = .true. - phi_end(phi_n) = flag - endif - endif - enddo -! Take care of the last one if need to wrap around - if (phi_end(phi_n) .eq. flag) then - index = 0 - do while ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) - index=index+1 - enddo - phi_end(phi_n) = res_ang(index) + 2.*PI - phi_n=phi_n+1 - endif - endif - - return - end subroutine construct_ranges -!----------------------------------------------------------------------------- - subroutine fix_no_moves(phi) -! implicit none - -! Includes -! include 'COMMON.GEO' -! include 'COMMON.LOCMOVE' - -! Output arguments - real(kind=8) :: phi - -! Local variables - integer :: index - real(kind=8) :: diff,temp - - -! Look for first 01x in gammas (there MUST be at least one) - diff = flag - index = 0 - do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) - index=index+1 - enddo - if (res_ang(index) .le. 0.D0) then ! Make sure it's from PHImax -! Try to increase PHImax - if (index .gt. 0) then - phi = res_ang(index-1) - diff = abs(res_ang(index) - res_ang(index-1)) - endif -! Look for last (corresponding) x10 - index = res_n - 1 - do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) - index=index-1 - enddo - if (index .lt. res_n-1) then - temp = abs(res_ang(index) - res_ang(index+1)) - if (temp .lt. diff) then - phi = res_ang(index+1) - diff = temp - endif - endif - endif - -! If increasing PHImax didn't work, decreasing PHImin -! will (with one exception) -! Look for first x10 (there MUST be at least one) - index = 0 - do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) - index=index+1 - enddo - if (res_ang(index) .lt. 0.D0) then ! Make sure it's from PHImin -! Try to decrease PHImin - if (index .lt. res_n-1) then - temp = abs(res_ang(index) - res_ang(index+1)) - if (res_ang(index+1) .le. 0.D0 .and. temp .lt. diff) then - phi = res_ang(index+1) - diff = temp - endif - endif -! Look for last (corresponding) 01x - index = res_n - 1 - do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) - index=index-1 - enddo - if (index .gt. 0) then - temp = abs(res_ang(index) - res_ang(index-1)) - if (res_ang(index-1) .ge. 0.D0 .and. temp .lt. diff) then - phi = res_ang(index-1) - diff = temp - endif - endif - endif - -! If it still didn't work, it must be PHImax == 0. or PHImin == PI - if (diff .eq. flag) then - index = 0 - if (res_tab(index,1,0) .or. (.not.res_tab(index,1,1)) .or. & - res_tab(index,1,2)) index = res_n - 1 -! This MUST work at this point - if (index .eq. 0) then - phi = res_ang(1) - else - phi = res_ang(index - 1) - endif - endif - - return - end subroutine fix_no_moves -!----------------------------------------------------------------------------- - integer function move_res(PHImin,PHImax,i_move) -! Moves residue i_move (in array c), leaving everything else fixed -! Starting geometry is not checked, it should be correct! -! R(,i_move) is the only residue that will move, but must have -! 1 < i_move < nres (i.e., cannot move ends) -! Whether any output is done is controlled by locmove_output -!rc implicit none - use random,only:ran_number -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.LOCMOVE' - -! External functions -!EL double precision ran_number -!EL external ran_number - -! Input arguments - real(kind=8) :: PHImin,PHImax - integer :: i_move - -! RETURN VALUES: -! 0: move successfull -! 1: Dmin or Dmax had to be modified -! 2: move failed - check your input geometry - - -! Local variables - real(kind=8),dimension(0:2) :: X,Y,Z,Orig - real(kind=8),dimension(0:2) :: P - logical :: no_moves,done - integer :: index,i,j - real(kind=8) :: phi,temp,radius - real(kind=8),dimension(0:11) :: phi_start,phi_end - integer :: phi_n - -! Set up the coordinate system - do i=0,2 - Orig(i)=0.5*(c(i+1,i_move-1)+c(i+1,i_move+1)) ! Position of origin - enddo - - do i=0,2 - Z(i)=c(i+1,i_move+1)-c(i+1,i_move-1) - enddo - temp=sqrt(Z(0)*Z(0)+Z(1)*Z(1)+Z(2)*Z(2)) - do i=0,2 - Z(i)=Z(i)/temp - enddo - - do i=0,2 - X(i)=c(i+1,i_move)-Orig(i) - enddo -! radius is the radius of the circle on which c(,i_move) can move - radius=sqrt(X(0)*X(0)+X(1)*X(1)+X(2)*X(2)) - do i=0,2 - X(i)=X(i)/radius - enddo - - Y(0)=Z(1)*X(2)-X(1)*Z(2) - Y(1)=X(0)*Z(2)-Z(0)*X(2) - Y(2)=Z(0)*X(1)-X(0)*Z(1) - -! Calculate min, max angles coming from dmin, dmax to c(,i_move-2) - if (i_move.gt.2) then - do i=0,2 - P(i)=c(i+1,i_move-2)-Orig(i) - enddo - call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2),& - P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2),& - P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2),& - radius,a_n,a_ang,a_tab) - else - a_n=0 - endif - -! Calculate min, max angles coming from dmin, dmax to c(,i_move+2) - if (i_move.lt.nres-2) then - do i=0,2 - P(i)=c(i+1,i_move+2)-Orig(i) - enddo - call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2),& - P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2),& - P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2),& - radius,b_n,b_ang,b_tab) - else - b_n=0 - endif - -! Construct the resulting table for alpha and beta - call construct_tab() - - if (locmove_output) then - print *,'ALPHAS & BETAS TABLE' - call output_tabs() - endif - -! Check that there is at least one possible move - no_moves = .true. - if (res_n .eq. 0) then - no_moves = .false. - else - index = 0 - do while ((index .lt. res_n) .and. no_moves) - if (res_tab(2,1,index)) no_moves = .false. - index=index+1 - enddo - endif - if (no_moves) then - if (locmove_output) print *,' *** Cannot move anywhere' - move_res=2 - return - endif - -! Transfer res_... into a_... - a_n = 0 - do i=0,res_n-1 - if ( (res_tab(2,0,i).neqv.res_tab(2,1,i)) .or. & - (res_tab(2,0,i).neqv.res_tab(2,2,i)) ) then - a_ang(a_n) = res_ang(i) - do j=0,2 - a_tab(j,a_n) = res_tab(2,j,i) - enddo - a_n=a_n+1 - endif - enddo - -! Check that the PHI's are within [0,PI] - if (PHImin .lt. 0. .or. abs(PHImin) .lt. small) PHImin = -flag - if (PHImin .gt. PI .or. abs(PHImin-PI) .lt. small) PHImin = PI - if (PHImax .gt. PI .or. abs(PHImax-PI) .lt. small) PHImax = flag - if (PHImax .lt. 0. .or. abs(PHImax) .lt. small) PHImax = 0. - if (PHImax .lt. PHImin) PHImax = PHImin -! Calculate min and max angles coming from PHImin and PHImax, -! and put them in b_... - call angles2tab(PHImin, PHImax, b_n, b_ang, b_tab) -! Construct the final table - call construct_tab() - - if (locmove_output) then - print *,'FINAL TABLE' - call output_tabs() - endif - -! Check that there is at least one possible move - no_moves = .true. - if (res_n .eq. 0) then - no_moves = .false. - else - index = 0 - do while ((index .lt. res_n) .and. no_moves) - if (res_tab(2,1,index)) no_moves = .false. - index=index+1 - enddo - endif - - if (no_moves) then -! Take care of the case where no solution exists... - call fix_no_moves(phi) - if (locmove_output) then - print *,' *** Had to modify PHImin or PHImax' - print *,'phi: ',phi*rad2deg - endif - move_res=1 - else -! ...or calculate the solution -! Construct phi_start/phi_end arrays - call construct_ranges(phi_n, phi_start, phi_end) -! Choose random angle phi in allowed range(s) - temp = 0. - do i=0,phi_n-1 - temp = temp + phi_end(i) - phi_start(i) - enddo - phi = ran_number(phi_start(0),phi_start(0)+temp) - index = 0 - done = .false. - do while (.not.done) - if (phi .lt. phi_end(index)) then - done = .true. - else - index=index+1 - endif - if (index .eq. phi_n) then - done = .true. - else if (.not.done) then - phi = phi + phi_start(index) - phi_end(index-1) - endif - enddo - if (index.eq.phi_n) phi=phi_end(phi_n-1) ! Fix numerical errors - if (phi .gt. PI) phi = phi-2.*PI - - if (locmove_output) then - print *,'ALLOWED RANGE(S)' - do i=0,phi_n-1 - print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg - enddo - print *,'phi: ',phi*rad2deg - endif - move_res=0 - endif - -! Re-use radius as temp variable - temp=radius*cos(phi) - radius=radius*sin(phi) - do i=0,2 - c(i+1,i_move)=Orig(i)+temp*X(i)+radius*Y(i) - enddo - - return - end function move_res -!----------------------------------------------------------------------------- - subroutine loc_test -!rc implicit none - -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.LOCMOVE' - -! External functions -!EL integer move_res -!EL external move_res - -! Local variables - integer :: i,j,imov - integer :: phi_n - real(kind=8),dimension(0:11) :: phi_start,phi_end - real(kind=8) :: phi - real(kind=8),dimension(0:2,0:5) :: R - - locmove_output=.true. - -! call angles2tab(30.*deg2rad,70.*deg2rad,a_n,a_ang,a_tab) -! call angles2tab(80.*deg2rad,130.*deg2rad,b_n,b_ang,b_tab) -! call minmax_angles(0.D0,3.8D0,0.D0,3.8D0,b_n,b_ang,b_tab) -! call construct_tab -! call output_tabs - -! call construct_ranges(phi_n,phi_start,phi_end) -! do i=0,phi_n-1 -! print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg -! enddo - -! call fix_no_moves(phi) -! print *,'NO MOVES FOUND, BEST PHI IS',phi*rad2deg - - R(0,0)=0.D0 - R(1,0)=0.D0 - R(2,0)=0.D0 - R(0,1)=0.D0 - R(1,1)=-cos(28.D0*deg2rad) - R(2,1)=-0.5D0-sin(28.D0*deg2rad) - R(0,2)=0.D0 - R(1,2)=0.D0 - R(2,2)=-0.5D0 - R(0,3)=cos(30.D0*deg2rad) - R(1,3)=0.D0 - R(2,3)=0.D0 - R(0,4)=0.D0 - R(1,4)=0.D0 - R(2,4)=0.5D0 - R(0,5)=0.D0 - R(1,5)=cos(26.D0*deg2rad) - R(2,5)=0.5D0+sin(26.D0*deg2rad) - do i=1,5 - do j=0,2 - R(j,i)=vbl*R(j,i) - enddo - enddo -! i=move_res(R(0,1),0.D0*deg2rad,180.D0*deg2rad) - imov=2 - i=move_res(0.D0*deg2rad,180.D0*deg2rad,imov) - print *,'RETURNED ',i - print *,(R(i,3)/vbl,i=0,2) - - return - end subroutine loc_test -#endif -!----------------------------------------------------------------------------- -! matmult.f -!----------------------------------------------------------------------------- - subroutine MATMULT(A1,A2,A3) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -!el local variables - integer :: i,j,k - real(kind=8) :: A3IJ - - real(kind=8),DIMENSION(3,3) :: A1,A2,A3 - real(kind=8),DIMENSION(3,3) :: AI3 - DO 1 I=1,3 - DO 2 J=1,3 - A3IJ=0.0 - DO 3 K=1,3 - 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) - AI3(I,J)=A3IJ - 2 CONTINUE - 1 CONTINUE - DO 4 I=1,3 - DO 4 J=1,3 - 4 A3(I,J)=AI3(I,J) - return - end subroutine MATMULT -!----------------------------------------------------------------------------- -! readpdb.F -!----------------------------------------------------------------------------- - subroutine int_from_cart(lside,lprn) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use control_data,only:out1file -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.NAMES' -! include 'COMMON.CONTROL' -! include 'COMMON.SETUP' - character(len=3) :: seq,res -! character*5 atom - character(len=80) :: card - real(kind=8),dimension(3,20) :: sccor - integer :: i,j,iti !el rescode, - logical :: lside,lprn - real(kind=8) :: di,cosfac,sinfac - integer :: nres2 - nres2=2*nres - - if(me.eq.king.or..not.out1file)then - if (lprn) then - write (iout,'(/a)') & - 'Internal coordinates calculated from crystal structure.' - if (lside) then - write (iout,'(8a)') ' Res ',' dvb',' Theta',& - ' Gamma',' Dsc_id',' Dsc',' Alpha',& - ' Beta ' - else - write (iout,'(4a)') ' Res ',' dvb',' Theta',& - ' Gamma' - endif - endif - endif - do i=1,nres-1 -!in wham do i=1,nres - iti=itype(i) - if (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0) then - write (iout,'(a,i4)') 'Bad Cartesians for residue',i -!test stop - endif -!#ifndef WHAM_RUN - vbld(i+1)=dist(i,i+1) - vbld_inv(i+1)=1.0d0/vbld(i+1) -!#endif - if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) - if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) - enddo -!el ----- -!#ifdef WHAM_RUN -! if (itype(1).eq.ntyp1) then -! do j=1,3 -! c(j,1)=c(j,2)+(c(j,3)-c(j,4)) -! enddo -! endif -! if (itype(nres).eq.ntyp1) then -! do j=1,3 -! c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3)) -! enddo -! endif -!#endif -! if (unres_pdb) then -! if (itype(1).eq.21) then -! theta(3)=90.0d0*deg2rad -! phi(4)=180.0d0*deg2rad -! vbld(2)=3.8d0 -! vbld_inv(2)=1.0d0/vbld(2) -! endif -! if (itype(nres).eq.21) then -! theta(nres)=90.0d0*deg2rad -! phi(nres)=180.0d0*deg2rad -! vbld(nres)=3.8d0 -! vbld_inv(nres)=1.0d0/vbld(2) -! endif -! endif - if (lside) then - do i=2,nres-1 - do j=1,3 - c(j,nres2+2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i) & - +(c(j,i+1)-c(j,i))*vbld_inv(i+1)) -! in wham c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1) - enddo - iti=itype(i) - di=dist(i,nres+i) -!#ifndef WHAM_RUN -! 10/03/12 Adam: Correction for zero SC-SC bond length - if (itype(i).ne.10 .and. itype(i).ne.ntyp1 .and. di.eq.0.0d0) & - di=dsc(itype(i)) - vbld(i+nres)=di - if (itype(i).ne.10) then - vbld_inv(i+nres)=1.0d0/di - else - vbld_inv(i+nres)=0.0d0 - endif -!#endif - if (iti.ne.10) then - alph(i)=alpha(nres+i,i,nres2+2) - omeg(i)=beta(nres+i,i,nres2+2,i+1) - endif - if(me.eq.king.or..not.out1file)then - if (lprn) & - write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i),& - rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i),& - rad2deg*alph(i),rad2deg*omeg(i) - endif - enddo - else if (lprn) then - do i=2,nres - iti=itype(i) - if(me.eq.king.or..not.out1file) & - write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1),& - rad2deg*theta(i),rad2deg*phi(i) - enddo - endif - return - end subroutine int_from_cart -!----------------------------------------------------------------------------- - subroutine sc_loc_geom(lprn) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use control_data,only:out1file -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.NAMES' -! include 'COMMON.CONTROL' -! include 'COMMON.SETUP' - real(kind=8),dimension(3) :: x_prime,y_prime,z_prime - logical :: lprn -!el local variables - integer :: i,j,it,iti - real(kind=8) :: cosfac2,sinfac2,xx,yy,zz,cosfac,sinfac - do i=1,nres-1 - do j=1,3 - dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) - enddo - enddo - do i=2,nres-1 - if (itype(i).ne.10) then - do j=1,3 - dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) - enddo - else - do j=1,3 - dc_norm(j,i+nres)=0.0d0 - enddo - endif - enddo - do i=2,nres-1 - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - - if ((it.ne.10).and.(it.ne.ntyp1)) then -!el if (it.ne.10) then -! -! Compute the axes of tghe local cartesian coordinates system; store in -! x_prime, y_prime and z_prime -! - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - call vecpr(x_prime,y_prime,z_prime) -! -! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -! to local coordinate system. Store in xx, yy, zz. -! - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxref(i)=xx - yyref(i)=yy - zzref(i)=zz - else - xxref(i)=0.0d0 - yyref(i)=0.0d0 - zzref(i)=0.0d0 - endif - enddo - if (lprn) then - do i=2,nres - iti=itype(i) - if(me.eq.king.or..not.out1file) & - write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),& - yyref(i),zzref(i) - enddo - endif - - return - end subroutine sc_loc_geom -!----------------------------------------------------------------------------- - subroutine sccenter(ires,nscat,sccor) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' - integer :: i,j,ires,nscat - real(kind=8),dimension(3,20) :: sccor - real(kind=8) :: sccmj - do j=1,3 - sccmj=0.0D0 - do i=1,nscat - sccmj=sccmj+sccor(j,i) - enddo - dc(j,ires)=sccmj/nscat - enddo - return - end subroutine sccenter -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- - subroutine bond_regular - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CALC' -! include 'COMMON.INTERACT' -! include 'COMMON.CHAIN' - do i=1,nres-1 - vbld(i+1)=vbl - vbld_inv(i+1)=1.0d0/vbld(i+1) - vbld(i+1+nres)=dsc(itype(i+1)) - vbld_inv(i+1+nres)=dsc_inv(itype(i+1)) -! print *,vbld(i+1),vbld(i+1+nres) - enddo - return - end subroutine bond_regular -#endif -!----------------------------------------------------------------------------- -! refsys.f -!----------------------------------------------------------------------------- - subroutine refsys(i2,i3,i4,e1,e2,e3,fail) -! This subroutine calculates unit vectors of a local reference system -! defined by atoms (i2), (i3), and (i4). The x axis is the axis from -! atom (i3) to atom (i2), and the xy plane is the plane defined by atoms -! (i2), (i3), and (i4). z axis is directed according to the sign of the -! vector product (i3)-(i2) and (i3)-(i4). Sets fail to .true. if atoms -! (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4) -! form a linear fragment. Returns vectors e1, e2, and e3. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - logical :: fail - real(kind=8),dimension(3) :: e1,e2,e3 - real(kind=8),dimension(3) :: u,z -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' - real(kind=8) :: coinc=1.0D-13,align=1.0D-13 -!el local variables - integer :: i,i1,i2,i3,i4 - real(kind=8) :: v1,v2,v3,s1,s2,zi,ui,anorm - fail=.false. - s1=0.0 - s2=0.0 - do 1 i=1,3 - zi=c(i,i2)-c(i,i3) - ui=c(i,i4)-c(i,i3) - s1=s1+zi*zi - s2=s2+ui*ui - z(i)=zi - 1 u(i)=ui - s1=sqrt(s1) - s2=sqrt(s2) - if (s1.gt.coinc) goto 2 - write (iout,1000) i2,i3,i1 - fail=.true. -! do 3 i=1,3 -! 3 c(i,i1)=0.0D0 - return - 2 if (s2.gt.coinc) goto 4 - write(iout,1000) i3,i4,i1 - fail=.true. - do 5 i=1,3 - 5 c(i,i1)=0.0D0 - return - 4 s1=1.0/s1 - s2=1.0/s2 - v1=z(2)*u(3)-z(3)*u(2) - v2=z(3)*u(1)-z(1)*u(3) - v3=z(1)*u(2)-z(2)*u(1) - anorm=dsqrt(v1*v1+v2*v2+v3*v3) - if (anorm.gt.align) goto 6 - write (iout,1010) i2,i3,i4,i1 - fail=.true. -! do 7 i=1,3 -! 7 c(i,i1)=0.0D0 - return - 6 anorm=1.0D0/anorm - e3(1)=v1*anorm - e3(2)=v2*anorm - e3(3)=v3*anorm - e1(1)=z(1)*s1 - e1(2)=z(2)*s1 - e1(3)=z(3)*s1 - e2(1)=e1(3)*e3(2)-e1(2)*e3(3) - e2(2)=e1(1)*e3(3)-e1(3)*e3(1) - e2(3)=e1(2)*e3(1)-e1(1)*e3(2) - 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.',& - 'coordinates of atom',i4,' are set to zero.') - 1010 format (/1x,' * * * Error - atoms',2(i4,2h, ),i4,' form a linear',& - ' fragment. coordinates of atom',i4,' are set to zero.') - return - end subroutine refsys -!----------------------------------------------------------------------------- -! int_to_cart.f -!----------------------------------------------------------------------------- - subroutine int_to_cart -!-------------------------------------------------------------- -! This subroutine converts the energy derivatives from internal -! coordinates to cartesian coordinates -!------------------------------------------------------------- -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.SCCOR' -! calculating dE/ddc1 -!el local variables - integer :: j,i - if (nres.lt.3) go to 18 - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4) & - +gloc(nres-2,icg)*dtheta(j,1,3) - if(itype(2).ne.10) then - gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+ & - gloc(ialph(2,1)+nside,icg)*domega(j,1,2) - endif - enddo -! Calculating the remainder of dE/ddc2 - do j=1,3 - gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+ & - gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4) - if(itype(2).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+ & - gloc(ialph(2,1)+nside,icg)*domega(j,2,2) - endif - if(itype(3).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+ & - gloc(ialph(3,1)+nside,icg)*domega(j,1,3) - endif - if(nres.gt.4) then - gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5) - endif - enddo -! If there are only five residues - if(nres.eq.5) then - do j=1,3 - gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)* & - dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)* & - dtheta(j,1,5) - if(itype(3).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)* & - dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3) - endif - if(itype(4).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)* & - dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4) - endif - enddo - endif -! If there are more than five residues - if(nres.gt.5) then - do i=3,nres-3 - do j=1,3 - gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1) & - +gloc(i-1,icg)*dphi(j,2,i+2)+ & - gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+ & - gloc(nres+i-3,icg)*dtheta(j,1,i+2) - if(itype(i).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+ & - gloc(ialph(i,1)+nside,icg)*domega(j,2,i) - endif - if(itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1) & - +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1) - endif - enddo - enddo - endif -! Setting dE/ddnres-2 - if(nres.gt.5) then - do j=1,3 - gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)* & - dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres) & - +gloc(2*nres-6,icg)* & - dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres) - if(itype(nres-2).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)* & - dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)* & - domega(j,2,nres-2) - endif - if(itype(nres-1).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)* & - dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* & - domega(j,1,nres-1) - endif - enddo - endif -! Settind dE/ddnres-1 - do j=1,3 - gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+ & - gloc(2*nres-5,icg)*dtheta(j,2,nres) - if(itype(nres-1).ne.10) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)* & - dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* & - domega(j,2,nres-1) - endif - enddo -! The side-chain vector derivatives - do i=2,nres-1 - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i) & - +gloc(ialph(i,1)+nside,icg)*domega(j,3,i) - enddo - endif - enddo -!---------------------------------------------------------------------- -! INTERTYP=1 SC...Ca...Ca...Ca -! INTERTYP=2 Ca...Ca...Ca...SC -! INTERTYP=3 SC...Ca...Ca...SC -! calculating dE/ddc1 - 18 continue -! do i=1,nres -! gloc(i,icg)=0.0D0 -! write (iout,*) "poczotkoawy",i,gloc_sc(1,i,icg) -! enddo - if (nres.lt.2) return - if ((nres.lt.3).and.(itype(1).eq.10)) return - if ((itype(1).ne.10).and.(itype(1).ne.ntyp1)) then - do j=1,3 -!c Derviative was calculated for oposite vector of side chain therefore -! there is "-" sign before gloc_sc - gxcart(j,1)=gxcart(j,1)-gloc_sc(1,0,icg)* & - dtauangle(j,1,1,3) - gcart(j,1)=gcart(j,1)+gloc_sc(1,0,icg)* & - dtauangle(j,1,2,3) - if ((itype(2).ne.10).and.(itype(2).ne.ntyp1)) then - gxcart(j,1)= gxcart(j,1) & - -gloc_sc(3,0,icg)*dtauangle(j,3,1,3) - gcart(j,1)=gcart(j,1)+gloc_sc(3,0,icg)* & - dtauangle(j,3,2,3) - endif - enddo - endif - if ((nres.ge.3).and.(itype(3).ne.10).and.(itype(3).ne.ntyp1)) & - then - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc_sc(2,1,icg)*dtauangle(j,2,1,4) - enddo - endif -! As potetnial DO NOT depend on omicron anlge their derivative is -! ommited -! & +gloc_sc(intertyp,nres-2,icg)*dtheta(j,1,3) - -! Calculating the remainder of dE/ddc2 - do j=1,3 - if((itype(2).ne.10).and.(itype(2).ne.ntyp1)) then - if (itype(1).ne.10) gxcart(j,2)=gxcart(j,2)+ & - gloc_sc(3,0,icg)*dtauangle(j,3,3,3) - if ((itype(3).ne.10).and.(nres.ge.3).and.(itype(3).ne.ntyp1)) & - then - gxcart(j,2)=gxcart(j,2)-gloc_sc(3,1,icg)*dtauangle(j,3,1,4) -!c the - above is due to different vector direction - gcart(j,2)=gcart(j,2)+gloc_sc(3,1,icg)*dtauangle(j,3,2,4) - endif - if (nres.gt.3) then - gxcart(j,2)=gxcart(j,2)-gloc_sc(1,1,icg)*dtauangle(j,1,1,4) -!c the - above is due to different vector direction - gcart(j,2)=gcart(j,2)+gloc_sc(1,1,icg)*dtauangle(j,1,2,4) -! write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,2,4),"gcart" -! write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,1,4),"gx" - endif - endif - if ((itype(1).ne.10).and.(itype(1).ne.ntyp1)) then - gcart(j,2)=gcart(j,2)+gloc_sc(1,0,icg)*dtauangle(j,1,3,3) -! write(iout,*) gloc_sc(1,0,icg),dtauangle(j,1,3,3) - endif - if ((itype(3).ne.10).and.(nres.ge.3)) then - gcart(j,2)=gcart(j,2)+gloc_sc(2,1,icg)*dtauangle(j,2,2,4) -! write(iout,*) gloc_sc(2,1,icg),dtauangle(j,2,2,4) - endif - if ((itype(4).ne.10).and.(nres.ge.4)) then - gcart(j,2)=gcart(j,2)+gloc_sc(2,2,icg)*dtauangle(j,2,1,5) -! write(iout,*) gloc_sc(2,2,icg),dtauangle(j,2,1,5) - endif - -! write(iout,*) gcart(j,2),itype(2),itype(1),itype(3), "gcart2" - enddo -! If there are more than five residues - if(nres.ge.5) then - do i=3,nres-2 - do j=1,3 -! write(iout,*) "before", gcart(j,i) - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - gxcart(j,i)=gxcart(j,i)+gloc_sc(2,i-2,icg) & - *dtauangle(j,2,3,i+1) & - -gloc_sc(1,i-1,icg)*dtauangle(j,1,1,i+2) - gcart(j,i)=gcart(j,i)+gloc_sc(1,i-1,icg) & - *dtauangle(j,1,2,i+2) -! write(iout,*) "new",j,i, -! & gcart(j,i),gloc_sc(1,i-1,icg),dtauangle(j,1,2,i+2) - if (itype(i-1).ne.10) then - gxcart(j,i)=gxcart(j,i)+gloc_sc(3,i-2,icg) & - *dtauangle(j,3,3,i+1) - endif - if (itype(i+1).ne.10) then - gxcart(j,i)=gxcart(j,i)-gloc_sc(3,i-1,icg) & - *dtauangle(j,3,1,i+2) - gcart(j,i)=gcart(j,i)+gloc_sc(3,i-1,icg) & - *dtauangle(j,3,2,i+2) - endif - endif - if (itype(i-1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(1,i-2,icg)* & - dtauangle(j,1,3,i+1) - endif - if (itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(2,i-1,icg)* & - dtauangle(j,2,2,i+2) -! write(iout,*) "numer",i,gloc_sc(2,i-1,icg), -! & dtauangle(j,2,2,i+2) - endif - if (itype(i+2).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(2,i,icg)* & - dtauangle(j,2,1,i+3) - endif - enddo - enddo - endif -! Setting dE/ddnres-1 - if(nres.ge.4) then - do j=1,3 - if ((itype(nres-1).ne.10).and.(itype(nres-1).ne.ntyp1)) then - gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(2,nres-3,icg) & - *dtauangle(j,2,3,nres) -! write (iout,*) "gxcart(nres-1)", gloc_sc(2,nres-3,icg), -! & dtauangle(j,2,3,nres), gxcart(j,nres-1) - if (itype(nres-2).ne.10) then - gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(3,nres-3,icg) & - *dtauangle(j,3,3,nres) - endif - if ((itype(nres).ne.10).and.(itype(nres).ne.ntyp1)) then - gxcart(j,nres-1)=gxcart(j,nres-1)-gloc_sc(3,nres-2,icg) & - *dtauangle(j,3,1,nres+1) - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(3,nres-2,icg) & - *dtauangle(j,3,2,nres+1) - endif - endif - if ((itype(nres-2).ne.10).and.(itype(nres-2).ne.ntyp1)) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(1,nres-3,icg)* & - dtauangle(j,1,3,nres) - endif - if ((itype(nres).ne.10).and.(itype(nres).ne.ntyp1)) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(2,nres-2,icg)* & - dtauangle(j,2,2,nres+1) -! write (iout,*) "gcart(nres-1)", gloc_sc(2,nres-2,icg), -! & dtauangle(j,2,2,nres+1), itype(nres-1),itype(nres) - endif - enddo - endif -! Settind dE/ddnres - if ((nres.ge.3).and.(itype(nres).ne.10).and. & - (itype(nres).ne.ntyp1))then - do j=1,3 - gxcart(j,nres)=gxcart(j,nres)+gloc_sc(3,nres-2,icg) & - *dtauangle(j,3,3,nres+1)+gloc_sc(2,nres-2,icg) & - *dtauangle(j,2,3,nres+1) - enddo - endif -! The side-chain vector derivatives - return - end subroutine int_to_cart -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - subroutine gen_dist_constr -! Generate CA distance constraints. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.LOCAL' -! include 'COMMON.NAMES' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' -! include 'COMMON.DBASE' -! include 'COMMON.THREAD' -! include 'COMMON.TIME1' -! integer :: itype_pdb !(maxres) -! common /pizda/ itype_pdb(nres) - character(len=2) :: iden -!el local variables - integer :: i,j -!d print *,'gen_dist_constr: nnt=',nnt,' nct=',nct -!d write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, -!d & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq, -!d & ' nsup',nsup - do i=nstart_sup,nstart_sup+nsup-1 -!d write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)), -!d & ' seq_pdb', restyp(itype_pdb(i)) - do j=i+2,nstart_sup+nsup-1 - nhpb=nhpb+1 - ihpb(nhpb)=i+nstart_seq-nstart_sup - jhpb(nhpb)=j+nstart_seq-nstart_sup - forcon(nhpb)=weidis - dhpb(nhpb)=dist(i,j) - enddo - enddo -!d write (iout,'(a)') 'Distance constraints:' -!d do i=nss+1,nhpb -!d ii=ihpb(i) -!d jj=jhpb(i) -!d iden='CA' -!d if (ii.gt.nres) then -!d iden='SC' -!d ii=ii-nres -!d jj=jj-nres -!d endif -!d write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)') -!d & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj, -!d & dhpb(i),forcon(i) -!d enddo -! deallocate(itype_pdb) - - return - end subroutine gen_dist_constr -#endif -!----------------------------------------------------------------------------- -! cartprint.f -!----------------------------------------------------------------------------- - subroutine cartprint - - use geometry_data, only: c - use energy_data, only: itype -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' - integer :: i - - write (iout,100) - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),& - c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) - enddo - 100 format (//' alpha-carbon coordinates ',& - ' centroid coordinates'/ & - ' ', 6X,'X',11X,'Y',11X,'Z',& - 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - return - end subroutine cartprint -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - subroutine alloc_geo_arrays -!EL Allocation of tables used by module energy - - integer :: i,j,nres2 - nres2=2*nres -! commom.bounds -! common /bounds/ - allocate(phibound(2,nres+2)) !(2,maxres) -!---------------------- -! commom.chain -! common /chain/ in molread -! real(kind=8),dimension(:,:),allocatable :: c !(3,maxres2+2) -! real(kind=8),dimension(:,:),allocatable :: dc - allocate(dc_old(3,0:nres2)) -! if(.not.allocated(dc_norm2)) allocate(dc_norm2(3,0:nres2+2)) !(3,0:maxres2) - if(.not.allocated(dc_norm2)) then - allocate(dc_norm2(3,0:nres2+2)) !(3,0:maxres2) - dc_norm2(:,:)=0.d0 - endif -! -!el if(.not.allocated(dc_norm)) -!elwrite(iout,*) "jestem w alloc geo 1" - if(.not.allocated(dc_norm)) then - allocate(dc_norm(3,0:nres2+2)) !(3,0:maxres2) - dc_norm(:,:)=0.d0 - endif -!elwrite(iout,*) "jestem w alloc geo 1" - allocate(xloc(3,nres),xrot(3,nres)) -!elwrite(iout,*) "jestem w alloc geo 1" - xloc(:,:)=0.0D0 -!elwrite(iout,*) "jestem w alloc geo 1" - allocate(dc_work(6*nres)) !(MAXRES6) maxres6=6*maxres -! common /rotmat/ - allocate(t(3,3,nres),r(3,3,nres)) - allocate(prod(3,3,nres),rt(3,3,nres)) !(3,3,maxres) -! common /refstruct/ - if(.not.allocated(cref)) allocate(cref(3,nres2+2,maxperm)) !(3,maxres2+2,maxperm) -!elwrite(iout,*) "jestem w alloc geo 2" - allocate(crefjlee(3,nres2+2)) !(3,maxres2+2) - if(.not.allocated(chain_rep)) allocate(chain_rep(3,nres2+2,maxsym)) !(3,maxres2+2,maxsym) - if(.not.allocated(tabperm)) allocate(tabperm(maxperm,maxsym)) !(maxperm,maxsym) -! common /from_zscore/ in module.compare -!---------------------- -! common.local -! Inverses of the actual virtual bond lengths -! common /invlen/ in io_conf: molread or readpdb -! real(kind=8),dimension(:),allocatable :: vbld_inv !(maxres2) -!---------------------- -! common.var -! Store the geometric variables in the following COMMON block. -! common /var/ in readpdb or ... - if(.not.allocated(theta)) allocate(theta(nres+2)) - if(.not.allocated(phi)) allocate(phi(nres+2)) - if(.not.allocated(alph)) allocate(alph(nres+2)) - if(.not.allocated(omeg)) allocate(omeg(nres+2)) - if(.not.allocated(thetaref)) allocate(thetaref(nres+2)) - if(.not.allocated(phiref)) allocate(phiref(nres+2)) - if(.not.allocated(costtab)) allocate(costtab(nres)) - if(.not.allocated(sinttab)) allocate(sinttab(nres)) - if(.not.allocated(cost2tab)) allocate(cost2tab(nres)) - if(.not.allocated(sint2tab)) allocate(sint2tab(nres)) -! real(kind=8),dimension(:),allocatable :: vbld !(2*maxres) in io_conf: molread or readpdb - allocate(omicron(2,nres+2)) !(2,maxres) - allocate(tauangle(3,nres+2)) !(3,maxres) -!elwrite(iout,*) "jestem w alloc geo 3" - if(.not.allocated(xxtab)) allocate(xxtab(nres)) - if(.not.allocated(yytab)) allocate(yytab(nres)) - if(.not.allocated(zztab)) allocate(zztab(nres)) !(maxres) - if(.not.allocated(xxref)) allocate(xxref(nres)) - if(.not.allocated(yyref)) allocate(yyref(nres)) - if(.not.allocated(zzref)) allocate(zzref(nres)) !(maxres) - allocate(ialph(nres,2)) !(maxres,2) - ialph(:,1)=0 - ialph(:,2)=0 - allocate(ivar(4*nres2)) !(4*maxres2) - -#if defined(WHAM_RUN) || defined(CLUSTER) - allocate(vbld(2*nres)) - vbld(:)=0.d0 - allocate(vbld_inv(2*nres)) - vbld_inv(:)=0.d0 -#endif - - return - end subroutine alloc_geo_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module geometry diff --git a/source/unres/io.F90 b/source/unres/io.F90 new file mode 100644 index 0000000..243c8b6 --- /dev/null +++ b/source/unres/io.F90 @@ -0,0 +1,1340 @@ + module io +!----------------------------------------------------------------------- + use io_units + use names + use io_base + use io_config + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! bank.F io_csa +!----------------------------------------------------------------------------- + subroutine write_csa_pdb(var,ene,nft,ik,iw_pdb) + + use csa_data + use geometry_data, only:nres,nvar + use geometry, only:var_to_geom,chainbuild + use compare, only:secondary2 +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.MINIM' +! include 'COMMON.SETUP' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.SBRIDGE' + integer :: lenpre,lenpot !,ilen +!el external ilen + real(kind=8),dimension(nvar) :: var !(maxvar) (maxvar=6*maxres) + character(len=50) :: titelloc + character(len=3) :: zahl + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: ene +!el local variables + integer :: nft,ik,iw_pdb + + nmin_csa=nmin_csa+1 + if(ene(1).lt.eglob_csa) then + eglob_csa=ene(1) + nglob_csa=nglob_csa+1 + call numstr(nglob_csa,zahl) + + call var_to_geom(nvar,var) + call chainbuild + call secondary2(.false.) + + lenpre=ilen(prefix) + open(icsa_pdb,file=prefix(:lenpre)//'@'//zahl//'.pdb') + + if (iw_pdb.eq.1) then + write(titelloc,'(a2,i3,a3,i9,a3,i6)') & + 'GM',nglob_csa,' e ',nft,' m ',nmin_csa + else + write(titelloc,'(a2,i3,a3,i9,a3,i6,a5,f5.2,a5,f5.1)') & + 'GM',nglob_csa,' e ',nft,' m ',nmin_csa,' rms ',& + rmsn(ik),' %NC ',pncn(ik)*100 + endif + call pdbout(eglob_csa,titelloc,icsa_pdb) + close(icsa_pdb) + endif + + return + end subroutine write_csa_pdb +!----------------------------------------------------------------------------- +! csa.f io_csa +!----------------------------------------------------------------------------- + subroutine from_pdb(n,idum) +! This subroutine stores the UNRES int variables generated from +! subroutine readpdb into the 1st conformation of in dihang_in. +! Subsequent n-1 conformations of dihang_in have identical values +! of theta and phi as the 1st conformation but random values for +! alph and omeg. +! The array cref (also generated from subroutine readpdb) is stored +! to crefjlee to be used for rmsd calculation in CSA, if necessary. + + use csa_data + use geometry_data + use random, only: ran1 +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.BANK' +! include 'COMMON.GEO' +!el local variables + integer :: n,idum,m,i,j,k,kk,kkk + real(kind=8) :: e + + m=1 + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + enddo + dihang_in(2,nres-1,1,k)=0.0d0 + + do m=2,n + do k=2,nres-1 + dihang_in(1,k,1,m)=dihang_in(1,k,1,1) + dihang_in(2,k,1,m)=dihang_in(2,k,1,1) + if(dabs(dihang_in(3,k,1,1)).gt.1.d-6) then + dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 + dihang_in(3,k,1,m)=dihang_in(3,k,1,m)*deg2rad + endif + if(dabs(dihang_in(4,k,1,1)).gt.1.d-6) then + dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 + dihang_in(4,k,1,m)=dihang_in(4,k,1,m)*deg2rad + endif + enddo + enddo + +! Store cref to crefjlee (they are in COMMON.CHAIN). + do k=1,2*nres + do kk=1,3 + kkk=1 + crefjlee(kk,k)=cref(kk,k,kkk) + enddo + enddo + + open(icsa_native_int,file=csa_native_int,status="old") + do m=1,n + write(icsa_native_int,*) m,e + write(icsa_native_int,200) & + (dihang_in(1,k,1,m)*rad2deg,k=2,nres-1) + write(icsa_native_int,200) & + (dihang_in(2,k,1,m)*rad2deg,k=2,nres-2) + write(icsa_native_int,200) & + (dihang_in(3,k,1,m)*rad2deg,k=2,nres-1) + write(icsa_native_int,200) & + (dihang_in(4,k,1,m)*rad2deg,k=2,nres-1) + enddo + + do k=1,nres + write(icsa_native_int,200) (crefjlee(i,k),i=1,3) + enddo + close(icsa_native_int) + + 200 format (8f10.4) + + return + end subroutine from_pdb +!----------------------------------------------------------------------------- + subroutine from_int(n,mm,idum) + + use csa_data + use geometry_data + use energy_data + use geometry, only:chainbuild,gen_side + use energy, only:etotal + use compare +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.BANK' +! include 'COMMON.GEO' +! include 'COMMON.CONTACTS' +! integer ilen +!el external ilen + logical :: fail + real(kind=8),dimension(0:n_ene) :: energia +!el local variables + integer :: n,mm,idum,i,ii,j,m,k,kk,maxcount_fail,icount_fail,maxsi + real(kind=8) :: co + + open(icsa_native_int,file=csa_native_int,status="old") + read (icsa_native_int,*) + call read_angles(icsa_native_int,*10) + goto 11 + 10 write (iout,'(2a)') "CHUJ NASTAPIL - error in ",& + csa_native_int(:ilen(csa_native_int)) + 11 continue + call intout + do j=2,nres-1 + dihang_in(1,j,1,1)=theta(j+1) + dihang_in(2,j,1,1)=phi(j+2) + dihang_in(3,j,1,1)=alph(j) + dihang_in(4,j,1,1)=omeg(j) + enddo + dihang_in(2,nres-1,1,1)=0.0d0 + +! read(icsa_native_int,*) ind,e +! read(icsa_native_int,200) (dihang_in(1,k,1,1),k=2,nres-1) +! read(icsa_native_int,200) (dihang_in(2,k,1,1),k=2,nres-2) +! read(icsa_native_int,200) (dihang_in(3,k,1,1),k=2,nres-1) +! read(icsa_native_int,200) (dihang_in(4,k,1,1),k=2,nres-1) +! dihang_in(2,nres-1,1,1)=0.d0 + + maxsi=100 + maxcount_fail=100 + + do m=mm+2,n +! do k=2,nres-1 +! dihang_in(1,k,1,m)=dihang_in(1,k,1,1) +! dihang_in(2,k,1,m)=dihang_in(2,k,1,1) +! if(abs(dihang_in(3,k,1,1)).gt.1.d-3) then +! dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 +! endif +! if(abs(dihang_in(4,k,1,1)).gt.1.d-3) then +! dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 +! endif +! enddo +! call intout + fail=.true. + + icount_fail=0 + + DO WHILE (FAIL .AND. ICOUNT_FAIL .LE. MAXCOUNT_FAIL) + + do i=nnt,nct + if (itype(i).ne.10) then +!d print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) + fail=.true. + ii=0 + do while (fail .and. ii .le. maxsi) + call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) + ii = ii+1 + enddo + endif + enddo + call chainbuild + call etotal(energia) + fail = (energia(0).ge.1.0d20) + icount_fail=icount_fail+1 + + ENDDO + + if (icount_fail.gt.maxcount_fail) then + write (iout,*) & + 'Failed to generate non-overlaping near-native conf.',& + m + endif + + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + enddo + dihang_in(2,nres-1,1,m)=0.0d0 + enddo + +! do m=1,n +! write(icsa_native_int,*) m,e +! write(icsa_native_int,200) (dihang_in(1,k,1,m),k=2,nres-1) +! write(icsa_native_int,200) (dihang_in(2,k,1,m),k=2,nres-2) +! write(icsa_native_int,200) (dihang_in(3,k,1,m),k=2,nres-1) +! write(icsa_native_int,200) (dihang_in(4,k,1,m),k=2,nres-1) +! enddo +! close(icsa_native_int) + +! do m=mm+2,n +! do i=1,4 +! do j=2,nres-1 +! dihang_in(i,j,1,m)=dihang_in(i,j,1,m)*deg2rad +! enddo +! enddo +! enddo + + call dihang_to_c(dihang_in(1,1,1,1)) + +! Store c to cref (they are in COMMON.CHAIN). + do k=1,2*nres + do kk=1,3 + crefjlee(kk,k)=c(kk,k) + enddo + enddo + + call contact(.true.,ncont_ref,icont_ref,co) + +! do k=1,nres +! write(icsa_native_int,200) (crefjlee(i,k),i=1,3) +! enddo + close(icsa_native_int) + + 200 format (8f10.4) + + return + end subroutine from_int +!----------------------------------------------------------------------------- + subroutine dihang_to_c(aarray) + + use geometry_data + use csa_data + use geometry, only:chainbuild +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.VAR' + integer :: i + real(kind=8),dimension(mxang,nres,mxch) :: aarray !(mxang,maxres,mxch) + +! do i=4,nres +! phi(i)=dihang_in(1,i-2,1,1) +! enddo + do i=2,nres-1 + theta(i+1)=aarray(1,i,1) + phi(i+2)=aarray(2,i,1) + alph(i)=aarray(3,i,1) + omeg(i)=aarray(4,i,1) + enddo + + call chainbuild + + return + end subroutine dihang_to_c +!----------------------------------------------------------------------------- +! geomout.F +!----------------------------------------------------------------------------- +#ifdef NOXDR + subroutine cartout(time) +#else + subroutine cartoutx(time) +#endif + use geometry_data, only: c,nres + use energy_data + use MD_data, only: potE,t_bath +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' +! include 'COMMON.DISTFIT' +! include 'COMMON.MD' + real(kind=8) :: time +!el local variables + integer :: j,k,i + +#if defined(AIX) || defined(PGI) + open(icart,file=cartname,position="append") +#else + open(icart,file=cartname,access="append") +#endif + write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath + if (dyn_ss) then + write (icart,'(i4,$)') & + nss,(idssb(j)+nres,jdssb(j)+nres,j=1,nss) + else + write (icart,'(i4,$)') & + nss,(ihpb(j),jhpb(j),j=1,nss) + endif + write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back,& + (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair),& + (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) + write (icart,'(8f10.5)') & + ((c(k,j),k=1,3),j=1,nres),& + ((c(k,j+nres),k=1,3),j=nnt,nct) + close(icart) + return + +#ifdef NOXDR + end subroutine cartout +#else + end subroutine cartoutx +#endif +!----------------------------------------------------------------------------- +#ifndef NOXDR + subroutine cartout(time) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use geometry_data, only: c,nres + use energy_data + use MD_data, only: potE,t_bath +#ifdef MPI + use MPI_data + include 'mpif.h' +! include 'COMMON.SETUP' +#else + integer,parameter :: me=0 +#endif +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' +! include 'COMMON.DISTFIT' +! include 'COMMON.MD' + real(kind=8) :: time + integer :: iret,itmp + real(kind=4) :: prec + real(kind=4),dimension(3,2*nres+2) :: xcoord !(3,maxres2+2) (maxres2=2*maxres +!el local variables + integer :: j,i,ixdrf + +#ifdef AIX + call xdrfopen_(ixdrf,cartname, "a", iret) + call xdrffloat_(ixdrf, real(time), iret) + call xdrffloat_(ixdrf, real(potE), iret) + call xdrffloat_(ixdrf, real(uconst), iret) + call xdrffloat_(ixdrf, real(uconst_back), iret) + call xdrffloat_(ixdrf, real(t_bath), iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint_(ixdrf, idssb(j)+nres, iret) + call xdrfint_(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) + do i=1,nfrag + call xdrffloat_(ixdrf, real(qfrag(i)), iret) + enddo + do i=1,npair + call xdrffloat_(ixdrf, real(qpair(i)), iret) + enddo + do i=1,nfrag_back + call xdrffloat_(ixdrf, real(utheta(i)), iret) + call xdrffloat_(ixdrf, real(ugamma(i)), iret) + call xdrffloat_(ixdrf, real(uscdiff(i)), iret) + enddo +#else + call xdrfopen(ixdrf,cartname, "a", iret) + call xdrffloat(ixdrf, real(time), iret) + call xdrffloat(ixdrf, real(potE), iret) + call xdrffloat(ixdrf, real(uconst), iret) + call xdrffloat(ixdrf, real(uconst_back), iret) + call xdrffloat(ixdrf, real(t_bath), iret) + call xdrfint(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) + do i=1,nfrag + call xdrffloat(ixdrf, real(qfrag(i)), iret) + enddo + do i=1,npair + call xdrffloat(ixdrf, real(qpair(i)), iret) + enddo + do i=1,nfrag_back + call xdrffloat(ixdrf, real(utheta(i)), iret) + call xdrffloat(ixdrf, real(ugamma(i)), iret) + call xdrffloat(ixdrf, real(uscdiff(i)), iret) + enddo +#endif + prec=10000.0 + do i=1,nres + do j=1,3 + xcoord(j,i)=c(j,i) + enddo + enddo + do i=nnt,nct + do j=1,3 + xcoord(j,nres+i-nnt+1)=c(j,i+nres) + enddo + enddo + + itmp=nres+nct-nnt+1 +#ifdef AIX + call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) + call xdrfclose_(ixdrf, iret) +#else + call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) + call xdrfclose(ixdrf, iret) +#endif + return + end subroutine cartout +#endif +!----------------------------------------------------------------------------- + subroutine statout(itime) + + use energy_data + use control_data, only:refstr + use MD_data + use MPI_data + use compare, only:rms_nac_nnc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' +! include 'COMMON.DISTFIT' +! include 'COMMON.MD' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' + integer :: itime + real(kind=8),dimension(0:n_ene) :: energia +! double precision gyrate +!el external gyrate +!el common /gucio/ cm + character(len=256) :: line1,line2 + character(len=4) :: format1,format2 + character(len=30) :: format +!el local variables + integer :: i,ii1,ii2 + real(kind=8) :: rms,frac,frac_nn,co + +#ifdef AIX + if(itime.eq.0) then + open(istat,file=statname,position="append") + endif +#else +#ifdef PGI + open(istat,file=statname,position="append") +#else + open(istat,file=statname,access="append") +#endif +#endif + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.false.) + write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') & + itime,totT,EK,potE,totE,& + rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me + format1="a133" + else + write (line1,'(i10,f15.2,7f12.3,i5,$)') & + itime,totT,EK,potE,totE,& + amax,kinetic_T,t_bath,gyrate(),me + format1="a114" + endif + if(usampl.and.totT.gt.eq_time) then + write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,& + (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),& + (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) + write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair & + +21*nfrag_back + else + format2="a001" + line2=' ' + endif + if (print_compon) then + if(itime.eq.0) then + write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,& + ",20a12)" + write (istat,format) "#","",& + (ename(print_order(i)),i=1,nprint_ene) + endif + write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,& + ",20f12.3)" + write (istat,format) line1,line2,& + (potEcomp(print_order(i)),i=1,nprint_ene) + else + write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")" + write (istat,format) line1,line2 + endif +#if defined(AIX) + call flush(istat) +#else + close(istat) +#endif + return + end subroutine statout +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + subroutine readrtns + + use control_data + use energy_data + use MPI_data + use muca_md, only:read_muca +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.SBRIDGE' +! include 'COMMON.IOUNITS' + logical :: file_exist + integer :: i +! Read force-field parameters except weights + call parmread +! Read job setup parameters + call read_control +! Read control parameters for energy minimzation if required + if (minim) call read_minim +! Read MCM control parameters if required + if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread +! Read MD control parameters if reqjuired + if (modecalc.eq.12) call read_MDpar +! Read MREMD control parameters if required + if (modecalc.eq.14) then + call read_MDpar + call read_REMDpar + endif +! Read MUCA control parameters if required + if (lmuca) call read_muca +! Read CSA control parameters if required (from fort.40 if exists +! otherwise from general input file) + if (modecalc.eq.8) then + inquire (file="fort.40",exist=file_exist) + if (.not.file_exist) call csaread + endif +!fmc if (modecalc.eq.10) call mcmfread +! Read molecule information, molecule geometry, energy-term weights, and +! restraints if requested + call molread +! Print restraint information +#ifdef MPI + if (.not. out1file .or. me.eq.king) then +#endif + if (nhpb.gt.nss) & + write (iout,'(a,i5,a)') "The following",nhpb-nss,& + " distance constraints have been imposed" + do i=nss+1,nhpb + write (iout,'(3i6,f10.5)') i-nss,ihpb(i),jhpb(i),forcon(i) + enddo +#ifdef MPI + endif +#endif +! print *,"Processor",myrank," leaves READRTNS" +! write(iout,*) "end readrtns" + return + end subroutine readrtns +!----------------------------------------------------------------------------- + subroutine molread +! +! Read molecular data. +! +! use control, only: ilen + use control_data + use geometry_data + use energy_data + use energy + use compare_data + use MD_data, only: t_bath + use MPI_data + use compare, only:seq_comp,contact + use control +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer :: error_msg,ierror,ierr,ierrcode +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.LOCAL' +! include 'COMMON.NAMES' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' +! include 'COMMON.DBASE' +! include 'COMMON.THREAD' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORCNSTR' +! include 'COMMON.TIME1' +! include 'COMMON.BOUNDS' +! include 'COMMON.MD' +! include 'COMMON.SETUP' + character(len=4),dimension(:),allocatable :: sequence !(maxres) +! integer :: rescode +! double precision x(maxvar) + character(len=256) :: pdbfile + character(len=320) :: weightcard + character(len=80) :: weightcard_t!,ucase +! integer,dimension(:),allocatable :: itype_pdb !(maxres) +! common /pizda/ itype_pdb + logical :: fail !seq_comp, + real(kind=8) :: energia(0:n_ene) +! integer ilen +!el external ilen +!el local varables + integer :: i,j,l,k,kkk,ii,i1,i2,it1,it2 + + real(kind=8),dimension(3,maxres2+2) :: c_alloc + real(kind=8),dimension(3,0:maxres2) :: dc_alloc + integer,dimension(maxres) :: itype_alloc + + integer :: iti,nsi,maxsi,itrial,itmp + real(kind=8) :: wlong,scalscp,co + allocate(weights(n_ene)) +!----------------------------- + allocate(c(3,2*maxres+2)) !(3,maxres2+2) maxres2=2*maxres + allocate(dc(3,0:2*maxres)) !(3,0:maxres2) + allocate(itype(maxres)) !(maxres) +! +! Zero out tables. +! + c(:,:)=0.0D0 + dc(:,:)=0.0D0 + itype(:)=0 +!----------------------------- +! +! Body +! +! Read weights of the subsequent energy terms. + call card_concat(weightcard,.true.) + call reada(weightcard,'WLONG',wlong,1.0D0) + call reada(weightcard,'WSC',wsc,wlong) + call reada(weightcard,'WSCP',wscp,wlong) + call reada(weightcard,'WELEC',welec,1.0D0) + call reada(weightcard,'WVDWPP',wvdwpp,welec) + call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) + call reada(weightcard,'WCORR4',wcorr4,0.0D0) + call reada(weightcard,'WCORR5',wcorr5,0.0D0) + call reada(weightcard,'WCORR6',wcorr6,0.0D0) + call reada(weightcard,'WTURN3',wturn3,1.0D0) + call reada(weightcard,'WTURN4',wturn4,1.0D0) + call reada(weightcard,'WTURN6',wturn6,1.0D0) + call reada(weightcard,'WSCCOR',wsccor,1.0D0) + call reada(weightcard,'WSTRAIN',wstrain,1.0D0) + call reada(weightcard,'WBOND',wbond,1.0D0) + call reada(weightcard,'WTOR',wtor,1.0D0) + call reada(weightcard,'WTORD',wtor_d,1.0D0) + call reada(weightcard,'WANG',wang,1.0D0) + call reada(weightcard,'WSCLOC',wscloc,1.0D0) + call reada(weightcard,'SCAL14',scal14,0.4D0) + call reada(weightcard,'SCALSCP',scalscp,1.0d0) + call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) + call reada(weightcard,'TEMP0',temp0,300.0d0) + if (index(weightcard,'SOFT').gt.0) ipot=6 +! 12/1/95 Added weight for the multi-body term WCORR + call reada(weightcard,'WCORRH',wcorr,1.0D0) + if (wcorr4.gt.0.0d0) wcorr=wcorr4 + weights(1)=wsc + weights(2)=wscp + weights(3)=welec + weights(4)=wcorr + weights(5)=wcorr5 + weights(6)=wcorr6 + weights(7)=wel_loc + weights(8)=wturn3 + weights(9)=wturn4 + weights(10)=wturn6 + weights(11)=wang + weights(12)=wscloc + weights(13)=wtor + weights(14)=wtor_d + weights(15)=wstrain + weights(16)=wvdwpp + weights(17)=wbond + weights(18)=scal14 + weights(21)=wsccor + if(me.eq.king.or..not.out1file) & + write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,& + wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3,& + wturn4,wturn6 + 10 format (/'Energy-term weights (unscaled):'// & + 'WSCC= ',f10.6,' (SC-SC)'/ & + 'WSCP= ',f10.6,' (SC-p)'/ & + 'WELEC= ',f10.6,' (p-p electr)'/ & + 'WVDWPP= ',f10.6,' (p-p VDW)'/ & + 'WBOND= ',f10.6,' (stretching)'/ & + 'WANG= ',f10.6,' (bending)'/ & + 'WSCLOC= ',f10.6,' (SC local)'/ & + 'WTOR= ',f10.6,' (torsional)'/ & + 'WTORD= ',f10.6,' (double torsional)'/ & + 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & + 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ & + 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & + 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & + 'WCORR6= ',f10.6,' (multi-body 6th order)'/ & + 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ & + 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & + 'WTURN4= ',f10.6,' (turns, 4th order)'/ & + 'WTURN6= ',f10.6,' (turns, 6th order)') + if(me.eq.king.or..not.out1file)then + if (wcorr4.gt.0.0d0) then + write (iout,'(/2a/)') 'Local-electrostatic type correlation ',& + 'between contact pairs of peptide groups' + write (iout,'(2(a,f5.3/))') & + 'Cutoff on 4-6th order correlation terms: ',cutoff_corr,& + 'Range of quenching the correlation terms:',2*delt_corr + else if (wcorr.gt.0.0d0) then + write (iout,'(/2a/)') 'Hydrogen-bonding correlation ',& + 'between contact pairs of peptide groups' + endif + write (iout,'(a,f8.3)') & + 'Scaling factor of 1,4 SC-p interactions:',scal14 + write (iout,'(a,f8.3)') & + 'General scaling factor of SC-p interactions:',scalscp + endif + r0_corr=cutoff_corr-delt_corr + do i=1,ntyp + aad(i,1)=scalscp*aad(i,1) + aad(i,2)=scalscp*aad(i,2) + bad(i,1)=scalscp*bad(i,1) + bad(i,2)=scalscp*bad(i,2) + enddo + call rescale_weights(t_bath) + if(me.eq.king.or..not.out1file) & + write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,& + wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3,& + wturn4,wturn6 + 22 format (/'Energy-term weights (scaled):'// & + 'WSCC= ',f10.6,' (SC-SC)'/ & + 'WSCP= ',f10.6,' (SC-p)'/ & + 'WELEC= ',f10.6,' (p-p electr)'/ & + 'WVDWPP= ',f10.6,' (p-p VDW)'/ & + 'WBOND= ',f10.6,' (stretching)'/ & + 'WANG= ',f10.6,' (bending)'/ & + 'WSCLOC= ',f10.6,' (SC local)'/ & + 'WTOR= ',f10.6,' (torsional)'/ & + 'WTORD= ',f10.6,' (double torsional)'/ & + 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & + 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ & + 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & + 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & + 'WCORR6= ',f10.6,' (multi-body 6th order)'/ & + 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ & + 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & + 'WTURN4= ',f10.6,' (turns, 4th order)'/ & + 'WTURN6= ',f10.6,' (turns, 6th order)') + if(me.eq.king.or..not.out1file) & + write (iout,*) "Reference temperature for weights calculation:",& + temp0 + call reada(weightcard,"D0CM",d0cm,3.78d0) + call reada(weightcard,"AKCM",akcm,15.1d0) + call reada(weightcard,"AKTH",akth,11.0d0) + call reada(weightcard,"AKCT",akct,12.0d0) + call reada(weightcard,"V1SS",v1ss,-1.08d0) + call reada(weightcard,"V2SS",v2ss,7.61d0) + call reada(weightcard,"V3SS",v3ss,13.7d0) + call reada(weightcard,"EBR",ebr,-5.50D0) + dyn_ss=(index(weightcard,'DYN_SS').gt.0) + + call reada(weightcard,"HT",Ht,0.0D0) + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) + Ht=Ht/wsc-0.25*eps(1,1) + akcm=akcm*wstrain/wsc + akth=akth*wstrain/wsc + akct=akct*wstrain/wsc + v1ss=v1ss*wstrain/wsc + v2ss=v2ss*wstrain/wsc + v3ss=v3ss*wstrain/wsc + else + ss_depth=ebr/wstrain-0.25*eps(1,1)*wsc/wstrain + endif + + if(me.eq.king.or..not.out1file) then + write (iout,*) "Parameters of the SS-bond potential:" + write (iout,*) "D0CM",d0cm," AKCM",akcm," AKTH",akth,& + " AKCT",akct + write (iout,*) "V1SS",v1ss," V2SS",v2ss," V3SS",v3ss + write (iout,*) "EBR",ebr," SS_DEPTH",ss_depth + write (iout,*)" HT",Ht + print *,'indpdb=',indpdb,' pdbref=',pdbref + endif + if (indpdb.gt.0 .or. pdbref) then + read(inp,'(a)') pdbfile + if(me.eq.king.or..not.out1file) & + write (iout,'(2a)') 'PDB data will be read from file ',& + pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a)') 'Error opening PDB file.' + stop + 34 continue +! print *,'Begin reading pdb data' + call readpdb +! print *,'Finished reading pdb data' + if(me.eq.king.or..not.out1file) & + write (iout,'(a,i3,a,i3)')'nsup=',nsup,& + ' nstart_sup=',nstart_sup !,"ergwergewrgae" +!el if(.not.allocated(itype_pdb)) + allocate(itype_pdb(nres)) + do i=1,nres + itype_pdb(i)=itype(i) + enddo + close (ipdbin) + nnt=nstart_sup + nct=nstart_sup+nsup-1 +!el if(.not.allocated(icont_ref)) + allocate(icont_ref(2,12*nres)) ! maxcont=12*maxres + call contact(.false.,ncont_ref,icont_ref,co) + + if (sideadd) then + if(me.eq.king.or..not.out1file) & + write(iout,*)'Adding sidechains' + maxsi=1000 + do i=2,nres-1 + iti=itype(i) + if (iti.ne.10 .and. itype(i).ne.ntyp1) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) + nsi=nsi+1 + enddo + if(fail) write(iout,*)'Adding sidechain failed for res ',& + i,' after ',nsi,' trials' + endif + enddo + endif + endif + + if (indpdb.eq.0) then +! Read sequence if not taken from the pdb file. + read (inp,*) nres +! print *,'nres=',nres + allocate(sequence(nres)) + if (iscode.gt.0) then + read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) + else + read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) + endif +! Convert sequence to numeric code + do i=1,nres + itype(i)=rescode(i,sequence(i),iscode) + enddo +! Assign initial virtual bond lengths +!elwrite(iout,*) "test_alloc" + if(.not.allocated(vbld)) allocate(vbld(2*nres)) +!elwrite(iout,*) "test_alloc" + if(.not.allocated(vbld_inv)) allocate(vbld_inv(2*nres)) +!elwrite(iout,*) "test_alloc" + do i=2,nres + vbld(i)=vbl + vbld_inv(i)=vblinv + enddo + do i=2,nres-1 + vbld(i+nres)=dsc(iabs(itype(i))) + vbld_inv(i+nres)=dsc_inv(iabs(itype(i))) +! write (iout,*) "i",i," itype",itype(i), +! & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres) + enddo + endif +! print *,nres +! print '(20i4)',(itype(i),i=1,nres) +!---------------------------- +!el reallocate tables +! do i=1,maxres2 +! do j=1,3 +! c_alloc(j,i)=c(j,i) +! dc_alloc(j,i)=dc(j,i) +! enddo +! enddo +! do i=1,maxres +!elwrite(iout,*) "itype",i,itype(i) +! itype_alloc(i)=itype(i) +! enddo + +! deallocate(c) +! deallocate(dc) +! deallocate(itype) +! allocate(c(3,2*nres+4)) +! allocate(dc(3,0:2*nres+2)) +! allocate(itype(nres+2)) + allocate(itel(nres+2)) + itel(:)=0 + +! do i=1,2*nres+2 +! do j=1,3 +! c(j,i)=c_alloc(j,i) +! dc(j,i)=dc_alloc(j,i) +! enddo +! enddo +! do i=1,nres+2 +! itype(i)=itype_alloc(i) +! itel(i)=0 +! enddo +!-------------------------- + do i=1,nres +#ifdef PROCOR + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then +#else + if (itype(i).eq.ntyp1) then +#endif + itel(i)=0 +#ifdef PROCOR + else if (iabs(itype(i+1)).ne.20) then +#else + else if (iabs(itype(i)).ne.20) then +#endif + itel(i)=1 + else + itel(i)=2 + endif + enddo + if(me.eq.king.or..not.out1file)then + write (iout,*) "ITEL" + do i=1,nres-1 + write (iout,*) i,itype(i),itel(i) + enddo + print *,'Call Read_Bridge.' + endif + call read_bridge +!-------------------------------- +! znamy nres oraz nss można zaalokowac potrzebne tablice + call alloc_geo_arrays + call alloc_ener_arrays +!-------------------------------- +! 8/13/98 Set limits to generating the dihedral angles + do i=1,nres + phibound(1,i)=-pi + phibound(2,i)=pi + enddo + read (inp,*) ndih_constr + if (ndih_constr.gt.0) then + allocate(idih_constr(ndih_constr),idih_nconstr(ndih_constr)) !(maxdih_constr) + allocate(phi0(ndih_constr),drange(ndih_constr)) !(maxdih_constr) + read (inp,*) ftors + read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) + if(me.eq.king.or..not.out1file)then + write (iout,*) & + 'There are',ndih_constr,' constraints on phi angles.' + do i=1,ndih_constr + write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) + enddo + endif + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + if(me.eq.king.or..not.out1file) & + write (iout,*) 'FTORS',ftors + do i=1,ndih_constr + ii = idih_constr(i) + phibound(1,ii) = phi0(i)-drange(i) + phibound(2,ii) = phi0(i)+drange(i) + enddo + endif + nnt=1 +#ifdef MPI + if (me.eq.king) then +#endif + write (iout,'(a)') 'Boundaries in phi angle sampling:' + do i=1,nres + write (iout,'(a3,i5,2f10.1)') & + restyp(itype(i)),i,phibound(1,i)*rad2deg,phibound(2,i)*rad2deg + enddo +#ifdef MP + endif +#endif + nct=nres +!d print *,'NNT=',NNT,' NCT=',NCT + if (itype(1).eq.ntyp1) nnt=2 + if (itype(nres).eq.ntyp1) nct=nct-1 + if (pdbref) then + if(me.eq.king.or..not.out1file) & + write (iout,'(a,i3)') 'nsup=',nsup + nstart_seq=nnt + if (nsup.le.(nct-nnt+1)) then + do i=0,nct-nnt+1-nsup + if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then + nstart_seq=nnt+i + goto 111 + endif + enddo + write (iout,'(a)') & + 'Error - sequences to be superposed do not match.' + stop + else + do i=0,nsup-(nct-nnt+1) + if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) & + then + nstart_sup=nstart_sup+i + nsup=nct-nnt+1 + goto 111 + endif + enddo + write (iout,'(a)') & + 'Error - sequences to be superposed do not match.' + endif + 111 continue + if (nsup.eq.0) nsup=nct-nnt + if (nstart_sup.eq.0) nstart_sup=nnt + if (nstart_seq.eq.0) nstart_seq=nnt + if(me.eq.king.or..not.out1file) & + write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup,& + ' nstart_seq=',nstart_seq !,"242343453254" + endif +!--- Zscore rms ------- + if (nz_start.eq.0) nz_start=nnt + if (nz_end.eq.0 .and. nsup.gt.0) then + nz_end=nnt+nsup-1 + else if (nz_end.eq.0) then + nz_end=nct + endif + if(me.eq.king.or..not.out1file)then + write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end + write (iout,*) 'IZ_SC=',iz_sc + endif +!---------------------- + call init_int_table + if (refstr) then + if (.not.pdbref) then + call read_angles(inp,*38) + goto 39 + 38 write (iout,'(a)') 'Error reading reference structure.' +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) + stop 'Error reading reference structure' +#endif + 39 call chainbuild + call setup_var +!zscore call geom_to_var(nvar,coord_exp_zs(1,1)) + nstart_sup=nnt + nstart_seq=nnt + nsup=nct-nnt+1 + kkk=1 + do i=1,2*nres + do j=1,3 + cref(j,i,kkk)=c(j,i) + enddo + enddo + call contact(.true.,ncont_ref,icont_ref,co) + endif +! write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup + call flush(iout) + if (constr_dist.gt.0) call read_dist_constr + write (iout,*) "After read_dist_constr nhpb",nhpb + call hpb_partition + if(me.eq.king.or..not.out1file) & + write (iout,*) 'Contact order:',co + if (pdbref) then + if(me.eq.king.or..not.out1file) & + write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup + do i=1,ncont_ref + do j=1,2 + icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup + enddo + if(me.eq.king.or..not.out1file) & + write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ',& + icont_ref(1,i),' ',& + restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i) + enddo + endif + endif + if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4 & + .and. modecalc.ne.8 .and. modecalc.ne.9 .and. & + modecalc.ne.10) then +! If input structure hasn't been supplied from the PDB file read or generate +! initial geometry. + if (iranconf.eq.0 .and. .not. extconf) then + if(me.eq.king.or..not.out1file .and.fg_rank.eq.0) & + write (iout,'(a)') 'Initial geometry will be read in.' + if (read_cart) then + read(inp,'(8f10.5)',end=36,err=36) & + ((c(l,k),l=1,3),k=1,nres),& + ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "Exit READ_CART" + write (iout,'(8f10.5)') & + ((c(l,k),l=1,3),k=1,nres),& + ((c(l,k+nres),l=1,3),k=nnt,nct) + call int_from_cart1(.true.) + write (iout,*) "Finish INT_TO_CART" + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres) + enddo + endif + enddo + return + else + call read_angles(inp,*36) + endif + goto 37 + 36 write (iout,'(a)') 'Error reading angle file.' +#ifdef MPI + call mpi_finalize( MPI_COMM_WORLD,IERR ) +#endif + stop 'Error reading angle file.' + 37 continue + else if (extconf) then + if(me.eq.king.or..not.out1file .and. fg_rank.eq.0) & + write (iout,'(a)') 'Extended chain initial geometry.' + do i=3,nres + theta(i)=90d0*deg2rad + enddo + do i=4,nres + phi(i)=180d0*deg2rad + enddo + do i=2,nres-1 + alph(i)=110d0*deg2rad + enddo +!elwrite (iout,*)"alph(i)*deg2rad",(alph(i), i=1,nres) + do i=2,nres-1 + omeg(i)=-120d0*deg2rad + if (itype(i).le.0) omeg(i)=-omeg(i) + enddo + else + if(me.eq.king.or..not.out1file) & + write (iout,'(a)') 'Random-generated initial geometry.' + + +#ifdef MPI + if (me.eq.king .or. fg_rank.eq.0 .and. & + ( modecalc.eq.12 .or. modecalc.eq.14) ) then +#endif + do itrial=1,100 + itmp=1 + call gen_rand_conf(itmp,*30) + goto 40 + 30 write (iout,*) 'Failed to generate random conformation',& + ', itrial=',itrial + write (*,*) 'Processor:',me,& + ' Failed to generate random conformation',& + ' itrial=',itrial + call intout + +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + enddo + write (iout,'(a,i3,a)') 'Processor:',me,& + ' error in generating random conformation.' + write (*,'(a,i3,a)') 'Processor:',me,& + ' error in generating random conformation.' + call flush(iout) +#ifdef MPI + call MPI_Abort(mpi_comm_world,error_msg,ierrcode) + 40 continue + endif +#else + do itrial=1,100 + itmp=1 + call gen_rand_conf(itmp,*335) + goto 40 + 335 write (iout,*) 'Failed to generate random conformation',& + ', itrial=',itrial + write (*,*) 'Failed to generate random conformation',& + ', itrial=',itrial + enddo + write (iout,'(a,i3,a)') 'Processor:',me,& + ' error in generating random conformation.' + write (*,'(a,i3,a)') 'Processor:',me,& + ' error in generating random conformation.' + stop + 40 continue +#endif + endif + elseif (modecalc.eq.4) then + read (inp,'(a)') intinname + open (intin,file=intinname,status='old',err=333) + if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0) & + write (iout,'(a)') 'intinname',intinname + write (*,'(a)') 'Processor',myrank,' intinname',intinname + goto 334 + 333 write (iout,'(2a)') 'Error opening angle file ',intinname +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERR) +#endif + stop 'Error opening angle file.' + 334 continue + + endif +! Generate distance constraints, if the PDB structure is to be regularized. + if (nthread.gt.0) then + call read_threadbase + endif + call setup_var +!elwrite (iout,*)"alph(i)*deg2rad",(alph(i), i=1,nres) + if (me.eq.king .or. .not. out1file) & + call intout +!elwrite (iout,*)"alph(i)*rad2deg",(alph(i)*rad2deg, i=1,nres) + if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then + write (iout,'(/a,i3,a)') & + 'The chain contains',ns,' disulfide-bridging cysteines.' + write (iout,'(20i4)') (iss(i),i=1,ns) + if (dyn_ss) then + write(iout,*)"Running with dynamic disulfide-bond formation" + else + write (iout,'(/a/)') 'Pre-formed links are:' + do i=1,nss + i1=ihpb(i)-nres + i2=jhpb(i)-nres + it1=itype(i1) + it2=itype(i2) + if (me.eq.king.or..not.out1file) & + write (iout,'(2a,i3,3a,i3,a,3f10.3)') & + restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i),& + ebr,forcon(i) + enddo + write (iout,'(a)') + endif + endif + if (ns.gt.0.and.dyn_ss) then + do i=nss+1,nhpb + ihpb(i-nss)=ihpb(i) + jhpb(i-nss)=jhpb(i) + forcon(i-nss)=forcon(i) + dhpb(i-nss)=dhpb(i) + enddo + nhpb=nhpb-nss + nss=0 + call hpb_partition + do i=1,ns + dyn_ss_mask(iss(i))=.true. + enddo + endif + if (i2ndstr.gt.0) call secstrp2dihc +! call geom_to_var(nvar,x) +! call etotal(energia(0)) +! call enerprint(energia(0)) +! call briefout(0,etot) +! stop +!d write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT +!d write (iout,'(a)') 'Variable list:' +!d write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar) +#ifdef MPI + if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file)) & + write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)') & + 'Processor',myrank,': end reading molecular data.' +#endif + return + end subroutine molread +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module io diff --git a/source/unres/io.f90 b/source/unres/io.f90 deleted file mode 100644 index 243c8b6..0000000 --- a/source/unres/io.f90 +++ /dev/null @@ -1,1340 +0,0 @@ - module io -!----------------------------------------------------------------------- - use io_units - use names - use io_base - use io_config - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! bank.F io_csa -!----------------------------------------------------------------------------- - subroutine write_csa_pdb(var,ene,nft,ik,iw_pdb) - - use csa_data - use geometry_data, only:nres,nvar - use geometry, only:var_to_geom,chainbuild - use compare, only:secondary2 -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.MINIM' -! include 'COMMON.SETUP' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.SBRIDGE' - integer :: lenpre,lenpot !,ilen -!el external ilen - real(kind=8),dimension(nvar) :: var !(maxvar) (maxvar=6*maxres) - character(len=50) :: titelloc - character(len=3) :: zahl - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: ene -!el local variables - integer :: nft,ik,iw_pdb - - nmin_csa=nmin_csa+1 - if(ene(1).lt.eglob_csa) then - eglob_csa=ene(1) - nglob_csa=nglob_csa+1 - call numstr(nglob_csa,zahl) - - call var_to_geom(nvar,var) - call chainbuild - call secondary2(.false.) - - lenpre=ilen(prefix) - open(icsa_pdb,file=prefix(:lenpre)//'@'//zahl//'.pdb') - - if (iw_pdb.eq.1) then - write(titelloc,'(a2,i3,a3,i9,a3,i6)') & - 'GM',nglob_csa,' e ',nft,' m ',nmin_csa - else - write(titelloc,'(a2,i3,a3,i9,a3,i6,a5,f5.2,a5,f5.1)') & - 'GM',nglob_csa,' e ',nft,' m ',nmin_csa,' rms ',& - rmsn(ik),' %NC ',pncn(ik)*100 - endif - call pdbout(eglob_csa,titelloc,icsa_pdb) - close(icsa_pdb) - endif - - return - end subroutine write_csa_pdb -!----------------------------------------------------------------------------- -! csa.f io_csa -!----------------------------------------------------------------------------- - subroutine from_pdb(n,idum) -! This subroutine stores the UNRES int variables generated from -! subroutine readpdb into the 1st conformation of in dihang_in. -! Subsequent n-1 conformations of dihang_in have identical values -! of theta and phi as the 1st conformation but random values for -! alph and omeg. -! The array cref (also generated from subroutine readpdb) is stored -! to crefjlee to be used for rmsd calculation in CSA, if necessary. - - use csa_data - use geometry_data - use random, only: ran1 -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.BANK' -! include 'COMMON.GEO' -!el local variables - integer :: n,idum,m,i,j,k,kk,kkk - real(kind=8) :: e - - m=1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,k)=0.0d0 - - do m=2,n - do k=2,nres-1 - dihang_in(1,k,1,m)=dihang_in(1,k,1,1) - dihang_in(2,k,1,m)=dihang_in(2,k,1,1) - if(dabs(dihang_in(3,k,1,1)).gt.1.d-6) then - dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 - dihang_in(3,k,1,m)=dihang_in(3,k,1,m)*deg2rad - endif - if(dabs(dihang_in(4,k,1,1)).gt.1.d-6) then - dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 - dihang_in(4,k,1,m)=dihang_in(4,k,1,m)*deg2rad - endif - enddo - enddo - -! Store cref to crefjlee (they are in COMMON.CHAIN). - do k=1,2*nres - do kk=1,3 - kkk=1 - crefjlee(kk,k)=cref(kk,k,kkk) - enddo - enddo - - open(icsa_native_int,file=csa_native_int,status="old") - do m=1,n - write(icsa_native_int,*) m,e - write(icsa_native_int,200) & - (dihang_in(1,k,1,m)*rad2deg,k=2,nres-1) - write(icsa_native_int,200) & - (dihang_in(2,k,1,m)*rad2deg,k=2,nres-2) - write(icsa_native_int,200) & - (dihang_in(3,k,1,m)*rad2deg,k=2,nres-1) - write(icsa_native_int,200) & - (dihang_in(4,k,1,m)*rad2deg,k=2,nres-1) - enddo - - do k=1,nres - write(icsa_native_int,200) (crefjlee(i,k),i=1,3) - enddo - close(icsa_native_int) - - 200 format (8f10.4) - - return - end subroutine from_pdb -!----------------------------------------------------------------------------- - subroutine from_int(n,mm,idum) - - use csa_data - use geometry_data - use energy_data - use geometry, only:chainbuild,gen_side - use energy, only:etotal - use compare -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.BANK' -! include 'COMMON.GEO' -! include 'COMMON.CONTACTS' -! integer ilen -!el external ilen - logical :: fail - real(kind=8),dimension(0:n_ene) :: energia -!el local variables - integer :: n,mm,idum,i,ii,j,m,k,kk,maxcount_fail,icount_fail,maxsi - real(kind=8) :: co - - open(icsa_native_int,file=csa_native_int,status="old") - read (icsa_native_int,*) - call read_angles(icsa_native_int,*10) - goto 11 - 10 write (iout,'(2a)') "CHUJ NASTAPIL - error in ",& - csa_native_int(:ilen(csa_native_int)) - 11 continue - call intout - do j=2,nres-1 - dihang_in(1,j,1,1)=theta(j+1) - dihang_in(2,j,1,1)=phi(j+2) - dihang_in(3,j,1,1)=alph(j) - dihang_in(4,j,1,1)=omeg(j) - enddo - dihang_in(2,nres-1,1,1)=0.0d0 - -! read(icsa_native_int,*) ind,e -! read(icsa_native_int,200) (dihang_in(1,k,1,1),k=2,nres-1) -! read(icsa_native_int,200) (dihang_in(2,k,1,1),k=2,nres-2) -! read(icsa_native_int,200) (dihang_in(3,k,1,1),k=2,nres-1) -! read(icsa_native_int,200) (dihang_in(4,k,1,1),k=2,nres-1) -! dihang_in(2,nres-1,1,1)=0.d0 - - maxsi=100 - maxcount_fail=100 - - do m=mm+2,n -! do k=2,nres-1 -! dihang_in(1,k,1,m)=dihang_in(1,k,1,1) -! dihang_in(2,k,1,m)=dihang_in(2,k,1,1) -! if(abs(dihang_in(3,k,1,1)).gt.1.d-3) then -! dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 -! endif -! if(abs(dihang_in(4,k,1,1)).gt.1.d-3) then -! dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 -! endif -! enddo -! call intout - fail=.true. - - icount_fail=0 - - DO WHILE (FAIL .AND. ICOUNT_FAIL .LE. MAXCOUNT_FAIL) - - do i=nnt,nct - if (itype(i).ne.10) then -!d print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) - fail=.true. - ii=0 - do while (fail .and. ii .le. maxsi) - call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) - ii = ii+1 - enddo - endif - enddo - call chainbuild - call etotal(energia) - fail = (energia(0).ge.1.0d20) - icount_fail=icount_fail+1 - - ENDDO - - if (icount_fail.gt.maxcount_fail) then - write (iout,*) & - 'Failed to generate non-overlaping near-native conf.',& - m - endif - - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - enddo - -! do m=1,n -! write(icsa_native_int,*) m,e -! write(icsa_native_int,200) (dihang_in(1,k,1,m),k=2,nres-1) -! write(icsa_native_int,200) (dihang_in(2,k,1,m),k=2,nres-2) -! write(icsa_native_int,200) (dihang_in(3,k,1,m),k=2,nres-1) -! write(icsa_native_int,200) (dihang_in(4,k,1,m),k=2,nres-1) -! enddo -! close(icsa_native_int) - -! do m=mm+2,n -! do i=1,4 -! do j=2,nres-1 -! dihang_in(i,j,1,m)=dihang_in(i,j,1,m)*deg2rad -! enddo -! enddo -! enddo - - call dihang_to_c(dihang_in(1,1,1,1)) - -! Store c to cref (they are in COMMON.CHAIN). - do k=1,2*nres - do kk=1,3 - crefjlee(kk,k)=c(kk,k) - enddo - enddo - - call contact(.true.,ncont_ref,icont_ref,co) - -! do k=1,nres -! write(icsa_native_int,200) (crefjlee(i,k),i=1,3) -! enddo - close(icsa_native_int) - - 200 format (8f10.4) - - return - end subroutine from_int -!----------------------------------------------------------------------------- - subroutine dihang_to_c(aarray) - - use geometry_data - use csa_data - use geometry, only:chainbuild -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.VAR' - integer :: i - real(kind=8),dimension(mxang,nres,mxch) :: aarray !(mxang,maxres,mxch) - -! do i=4,nres -! phi(i)=dihang_in(1,i-2,1,1) -! enddo - do i=2,nres-1 - theta(i+1)=aarray(1,i,1) - phi(i+2)=aarray(2,i,1) - alph(i)=aarray(3,i,1) - omeg(i)=aarray(4,i,1) - enddo - - call chainbuild - - return - end subroutine dihang_to_c -!----------------------------------------------------------------------------- -! geomout.F -!----------------------------------------------------------------------------- -#ifdef NOXDR - subroutine cartout(time) -#else - subroutine cartoutx(time) -#endif - use geometry_data, only: c,nres - use energy_data - use MD_data, only: potE,t_bath -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' -! include 'COMMON.DISTFIT' -! include 'COMMON.MD' - real(kind=8) :: time -!el local variables - integer :: j,k,i - -#if defined(AIX) || defined(PGI) - open(icart,file=cartname,position="append") -#else - open(icart,file=cartname,access="append") -#endif - write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath - if (dyn_ss) then - write (icart,'(i4,$)') & - nss,(idssb(j)+nres,jdssb(j)+nres,j=1,nss) - else - write (icart,'(i4,$)') & - nss,(ihpb(j),jhpb(j),j=1,nss) - endif - write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back,& - (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair),& - (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write (icart,'(8f10.5)') & - ((c(k,j),k=1,3),j=1,nres),& - ((c(k,j+nres),k=1,3),j=nnt,nct) - close(icart) - return - -#ifdef NOXDR - end subroutine cartout -#else - end subroutine cartoutx -#endif -!----------------------------------------------------------------------------- -#ifndef NOXDR - subroutine cartout(time) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use geometry_data, only: c,nres - use energy_data - use MD_data, only: potE,t_bath -#ifdef MPI - use MPI_data - include 'mpif.h' -! include 'COMMON.SETUP' -#else - integer,parameter :: me=0 -#endif -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' -! include 'COMMON.DISTFIT' -! include 'COMMON.MD' - real(kind=8) :: time - integer :: iret,itmp - real(kind=4) :: prec - real(kind=4),dimension(3,2*nres+2) :: xcoord !(3,maxres2+2) (maxres2=2*maxres -!el local variables - integer :: j,i,ixdrf - -#ifdef AIX - call xdrfopen_(ixdrf,cartname, "a", iret) - call xdrffloat_(ixdrf, real(time), iret) - call xdrffloat_(ixdrf, real(potE), iret) - call xdrffloat_(ixdrf, real(uconst), iret) - call xdrffloat_(ixdrf, real(uconst_back), iret) - call xdrffloat_(ixdrf, real(t_bath), iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - if (dyn_ss) then - call xdrfint_(ixdrf, idssb(j)+nres, iret) - call xdrfint_(ixdrf, jdssb(j)+nres, iret) - else - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - endif - enddo - call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) - do i=1,nfrag - call xdrffloat_(ixdrf, real(qfrag(i)), iret) - enddo - do i=1,npair - call xdrffloat_(ixdrf, real(qpair(i)), iret) - enddo - do i=1,nfrag_back - call xdrffloat_(ixdrf, real(utheta(i)), iret) - call xdrffloat_(ixdrf, real(ugamma(i)), iret) - call xdrffloat_(ixdrf, real(uscdiff(i)), iret) - enddo -#else - call xdrfopen(ixdrf,cartname, "a", iret) - call xdrffloat(ixdrf, real(time), iret) - call xdrffloat(ixdrf, real(potE), iret) - call xdrffloat(ixdrf, real(uconst), iret) - call xdrffloat(ixdrf, real(uconst_back), iret) - call xdrffloat(ixdrf, real(t_bath), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - if (dyn_ss) then - call xdrfint(ixdrf, idssb(j)+nres, iret) - call xdrfint(ixdrf, jdssb(j)+nres, iret) - else - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - endif - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - do i=1,nfrag - call xdrffloat(ixdrf, real(qfrag(i)), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, real(qpair(i)), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, real(utheta(i)), iret) - call xdrffloat(ixdrf, real(ugamma(i)), iret) - call xdrffloat(ixdrf, real(uscdiff(i)), iret) - enddo -#endif - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=c(j,i) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=c(j,i+nres) - enddo - enddo - - itmp=nres+nct-nnt+1 -#ifdef AIX - call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) - call xdrfclose_(ixdrf, iret) -#else - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - call xdrfclose(ixdrf, iret) -#endif - return - end subroutine cartout -#endif -!----------------------------------------------------------------------------- - subroutine statout(itime) - - use energy_data - use control_data, only:refstr - use MD_data - use MPI_data - use compare, only:rms_nac_nnc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' -! include 'COMMON.DISTFIT' -! include 'COMMON.MD' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' - integer :: itime - real(kind=8),dimension(0:n_ene) :: energia -! double precision gyrate -!el external gyrate -!el common /gucio/ cm - character(len=256) :: line1,line2 - character(len=4) :: format1,format2 - character(len=30) :: format -!el local variables - integer :: i,ii1,ii2 - real(kind=8) :: rms,frac,frac_nn,co - -#ifdef AIX - if(itime.eq.0) then - open(istat,file=statname,position="append") - endif -#else -#ifdef PGI - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif -#endif - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.false.) - write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') & - itime,totT,EK,potE,totE,& - rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me - format1="a133" - else - write (line1,'(i10,f15.2,7f12.3,i5,$)') & - itime,totT,EK,potE,totE,& - amax,kinetic_T,t_bath,gyrate(),me - format1="a114" - endif - if(usampl.and.totT.gt.eq_time) then - write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,& - (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),& - (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair & - +21*nfrag_back - else - format2="a001" - line2=' ' - endif - if (print_compon) then - if(itime.eq.0) then - write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,& - ",20a12)" - write (istat,format) "#","",& - (ename(print_order(i)),i=1,nprint_ene) - endif - write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,& - ",20f12.3)" - write (istat,format) line1,line2,& - (potEcomp(print_order(i)),i=1,nprint_ene) - else - write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")" - write (istat,format) line1,line2 - endif -#if defined(AIX) - call flush(istat) -#else - close(istat) -#endif - return - end subroutine statout -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - subroutine readrtns - - use control_data - use energy_data - use MPI_data - use muca_md, only:read_muca -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.SBRIDGE' -! include 'COMMON.IOUNITS' - logical :: file_exist - integer :: i -! Read force-field parameters except weights - call parmread -! Read job setup parameters - call read_control -! Read control parameters for energy minimzation if required - if (minim) call read_minim -! Read MCM control parameters if required - if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread -! Read MD control parameters if reqjuired - if (modecalc.eq.12) call read_MDpar -! Read MREMD control parameters if required - if (modecalc.eq.14) then - call read_MDpar - call read_REMDpar - endif -! Read MUCA control parameters if required - if (lmuca) call read_muca -! Read CSA control parameters if required (from fort.40 if exists -! otherwise from general input file) - if (modecalc.eq.8) then - inquire (file="fort.40",exist=file_exist) - if (.not.file_exist) call csaread - endif -!fmc if (modecalc.eq.10) call mcmfread -! Read molecule information, molecule geometry, energy-term weights, and -! restraints if requested - call molread -! Print restraint information -#ifdef MPI - if (.not. out1file .or. me.eq.king) then -#endif - if (nhpb.gt.nss) & - write (iout,'(a,i5,a)') "The following",nhpb-nss,& - " distance constraints have been imposed" - do i=nss+1,nhpb - write (iout,'(3i6,f10.5)') i-nss,ihpb(i),jhpb(i),forcon(i) - enddo -#ifdef MPI - endif -#endif -! print *,"Processor",myrank," leaves READRTNS" -! write(iout,*) "end readrtns" - return - end subroutine readrtns -!----------------------------------------------------------------------------- - subroutine molread -! -! Read molecular data. -! -! use control, only: ilen - use control_data - use geometry_data - use energy_data - use energy - use compare_data - use MD_data, only: t_bath - use MPI_data - use compare, only:seq_comp,contact - use control -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer :: error_msg,ierror,ierr,ierrcode -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.LOCAL' -! include 'COMMON.NAMES' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' -! include 'COMMON.DBASE' -! include 'COMMON.THREAD' -! include 'COMMON.CONTACTS' -! include 'COMMON.TORCNSTR' -! include 'COMMON.TIME1' -! include 'COMMON.BOUNDS' -! include 'COMMON.MD' -! include 'COMMON.SETUP' - character(len=4),dimension(:),allocatable :: sequence !(maxres) -! integer :: rescode -! double precision x(maxvar) - character(len=256) :: pdbfile - character(len=320) :: weightcard - character(len=80) :: weightcard_t!,ucase -! integer,dimension(:),allocatable :: itype_pdb !(maxres) -! common /pizda/ itype_pdb - logical :: fail !seq_comp, - real(kind=8) :: energia(0:n_ene) -! integer ilen -!el external ilen -!el local varables - integer :: i,j,l,k,kkk,ii,i1,i2,it1,it2 - - real(kind=8),dimension(3,maxres2+2) :: c_alloc - real(kind=8),dimension(3,0:maxres2) :: dc_alloc - integer,dimension(maxres) :: itype_alloc - - integer :: iti,nsi,maxsi,itrial,itmp - real(kind=8) :: wlong,scalscp,co - allocate(weights(n_ene)) -!----------------------------- - allocate(c(3,2*maxres+2)) !(3,maxres2+2) maxres2=2*maxres - allocate(dc(3,0:2*maxres)) !(3,0:maxres2) - allocate(itype(maxres)) !(maxres) -! -! Zero out tables. -! - c(:,:)=0.0D0 - dc(:,:)=0.0D0 - itype(:)=0 -!----------------------------- -! -! Body -! -! Read weights of the subsequent energy terms. - call card_concat(weightcard,.true.) - call reada(weightcard,'WLONG',wlong,1.0D0) - call reada(weightcard,'WSC',wsc,wlong) - call reada(weightcard,'WSCP',wscp,wlong) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) - if (index(weightcard,'SOFT').gt.0) ipot=6 -! 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - weights(1)=wsc - weights(2)=wscp - weights(3)=welec - weights(4)=wcorr - weights(5)=wcorr5 - weights(6)=wcorr6 - weights(7)=wel_loc - weights(8)=wturn3 - weights(9)=wturn4 - weights(10)=wturn6 - weights(11)=wang - weights(12)=wscloc - weights(13)=wtor - weights(14)=wtor_d - weights(15)=wstrain - weights(16)=wvdwpp - weights(17)=wbond - weights(18)=scal14 - weights(21)=wsccor - if(me.eq.king.or..not.out1file) & - write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,& - wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3,& - wturn4,wturn6 - 10 format (/'Energy-term weights (unscaled):'// & - 'WSCC= ',f10.6,' (SC-SC)'/ & - 'WSCP= ',f10.6,' (SC-p)'/ & - 'WELEC= ',f10.6,' (p-p electr)'/ & - 'WVDWPP= ',f10.6,' (p-p VDW)'/ & - 'WBOND= ',f10.6,' (stretching)'/ & - 'WANG= ',f10.6,' (bending)'/ & - 'WSCLOC= ',f10.6,' (SC local)'/ & - 'WTOR= ',f10.6,' (torsional)'/ & - 'WTORD= ',f10.6,' (double torsional)'/ & - 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & - 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ & - 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & - 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & - 'WCORR6= ',f10.6,' (multi-body 6th order)'/ & - 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ & - 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & - 'WTURN4= ',f10.6,' (turns, 4th order)'/ & - 'WTURN6= ',f10.6,' (turns, 6th order)') - if(me.eq.king.or..not.out1file)then - if (wcorr4.gt.0.0d0) then - write (iout,'(/2a/)') 'Local-electrostatic type correlation ',& - 'between contact pairs of peptide groups' - write (iout,'(2(a,f5.3/))') & - 'Cutoff on 4-6th order correlation terms: ',cutoff_corr,& - 'Range of quenching the correlation terms:',2*delt_corr - else if (wcorr.gt.0.0d0) then - write (iout,'(/2a/)') 'Hydrogen-bonding correlation ',& - 'between contact pairs of peptide groups' - endif - write (iout,'(a,f8.3)') & - 'Scaling factor of 1,4 SC-p interactions:',scal14 - write (iout,'(a,f8.3)') & - 'General scaling factor of SC-p interactions:',scalscp - endif - r0_corr=cutoff_corr-delt_corr - do i=1,ntyp - aad(i,1)=scalscp*aad(i,1) - aad(i,2)=scalscp*aad(i,2) - bad(i,1)=scalscp*bad(i,1) - bad(i,2)=scalscp*bad(i,2) - enddo - call rescale_weights(t_bath) - if(me.eq.king.or..not.out1file) & - write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,& - wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3,& - wturn4,wturn6 - 22 format (/'Energy-term weights (scaled):'// & - 'WSCC= ',f10.6,' (SC-SC)'/ & - 'WSCP= ',f10.6,' (SC-p)'/ & - 'WELEC= ',f10.6,' (p-p electr)'/ & - 'WVDWPP= ',f10.6,' (p-p VDW)'/ & - 'WBOND= ',f10.6,' (stretching)'/ & - 'WANG= ',f10.6,' (bending)'/ & - 'WSCLOC= ',f10.6,' (SC local)'/ & - 'WTOR= ',f10.6,' (torsional)'/ & - 'WTORD= ',f10.6,' (double torsional)'/ & - 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & - 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ & - 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & - 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & - 'WCORR6= ',f10.6,' (multi-body 6th order)'/ & - 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ & - 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & - 'WTURN4= ',f10.6,' (turns, 4th order)'/ & - 'WTURN6= ',f10.6,' (turns, 6th order)') - if(me.eq.king.or..not.out1file) & - write (iout,*) "Reference temperature for weights calculation:",& - temp0 - call reada(weightcard,"D0CM",d0cm,3.78d0) - call reada(weightcard,"AKCM",akcm,15.1d0) - call reada(weightcard,"AKTH",akth,11.0d0) - call reada(weightcard,"AKCT",akct,12.0d0) - call reada(weightcard,"V1SS",v1ss,-1.08d0) - call reada(weightcard,"V2SS",v2ss,7.61d0) - call reada(weightcard,"V3SS",v3ss,13.7d0) - call reada(weightcard,"EBR",ebr,-5.50D0) - dyn_ss=(index(weightcard,'DYN_SS').gt.0) - - call reada(weightcard,"HT",Ht,0.0D0) - if (dyn_ss) then - ss_depth=ebr/wsc-0.25*eps(1,1) - Ht=Ht/wsc-0.25*eps(1,1) - akcm=akcm*wstrain/wsc - akth=akth*wstrain/wsc - akct=akct*wstrain/wsc - v1ss=v1ss*wstrain/wsc - v2ss=v2ss*wstrain/wsc - v3ss=v3ss*wstrain/wsc - else - ss_depth=ebr/wstrain-0.25*eps(1,1)*wsc/wstrain - endif - - if(me.eq.king.or..not.out1file) then - write (iout,*) "Parameters of the SS-bond potential:" - write (iout,*) "D0CM",d0cm," AKCM",akcm," AKTH",akth,& - " AKCT",akct - write (iout,*) "V1SS",v1ss," V2SS",v2ss," V3SS",v3ss - write (iout,*) "EBR",ebr," SS_DEPTH",ss_depth - write (iout,*)" HT",Ht - print *,'indpdb=',indpdb,' pdbref=',pdbref - endif - if (indpdb.gt.0 .or. pdbref) then - read(inp,'(a)') pdbfile - if(me.eq.king.or..not.out1file) & - write (iout,'(2a)') 'PDB data will be read from file ',& - pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - stop - 34 continue -! print *,'Begin reading pdb data' - call readpdb -! print *,'Finished reading pdb data' - if(me.eq.king.or..not.out1file) & - write (iout,'(a,i3,a,i3)')'nsup=',nsup,& - ' nstart_sup=',nstart_sup !,"ergwergewrgae" -!el if(.not.allocated(itype_pdb)) - allocate(itype_pdb(nres)) - do i=1,nres - itype_pdb(i)=itype(i) - enddo - close (ipdbin) - nnt=nstart_sup - nct=nstart_sup+nsup-1 -!el if(.not.allocated(icont_ref)) - allocate(icont_ref(2,12*nres)) ! maxcont=12*maxres - call contact(.false.,ncont_ref,icont_ref,co) - - if (sideadd) then - if(me.eq.king.or..not.out1file) & - write(iout,*)'Adding sidechains' - maxsi=1000 - do i=2,nres-1 - iti=itype(i) - if (iti.ne.10 .and. itype(i).ne.ntyp1) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) write(iout,*)'Adding sidechain failed for res ',& - i,' after ',nsi,' trials' - endif - enddo - endif - endif - - if (indpdb.eq.0) then -! Read sequence if not taken from the pdb file. - read (inp,*) nres -! print *,'nres=',nres - allocate(sequence(nres)) - if (iscode.gt.0) then - read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) - else - read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) - endif -! Convert sequence to numeric code - do i=1,nres - itype(i)=rescode(i,sequence(i),iscode) - enddo -! Assign initial virtual bond lengths -!elwrite(iout,*) "test_alloc" - if(.not.allocated(vbld)) allocate(vbld(2*nres)) -!elwrite(iout,*) "test_alloc" - if(.not.allocated(vbld_inv)) allocate(vbld_inv(2*nres)) -!elwrite(iout,*) "test_alloc" - do i=2,nres - vbld(i)=vbl - vbld_inv(i)=vblinv - enddo - do i=2,nres-1 - vbld(i+nres)=dsc(iabs(itype(i))) - vbld_inv(i+nres)=dsc_inv(iabs(itype(i))) -! write (iout,*) "i",i," itype",itype(i), -! & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres) - enddo - endif -! print *,nres -! print '(20i4)',(itype(i),i=1,nres) -!---------------------------- -!el reallocate tables -! do i=1,maxres2 -! do j=1,3 -! c_alloc(j,i)=c(j,i) -! dc_alloc(j,i)=dc(j,i) -! enddo -! enddo -! do i=1,maxres -!elwrite(iout,*) "itype",i,itype(i) -! itype_alloc(i)=itype(i) -! enddo - -! deallocate(c) -! deallocate(dc) -! deallocate(itype) -! allocate(c(3,2*nres+4)) -! allocate(dc(3,0:2*nres+2)) -! allocate(itype(nres+2)) - allocate(itel(nres+2)) - itel(:)=0 - -! do i=1,2*nres+2 -! do j=1,3 -! c(j,i)=c_alloc(j,i) -! dc(j,i)=dc_alloc(j,i) -! enddo -! enddo -! do i=1,nres+2 -! itype(i)=itype_alloc(i) -! itel(i)=0 -! enddo -!-------------------------- - do i=1,nres -#ifdef PROCOR - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then -#else - if (itype(i).eq.ntyp1) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (iabs(itype(i+1)).ne.20) then -#else - else if (iabs(itype(i)).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - if(me.eq.king.or..not.out1file)then - write (iout,*) "ITEL" - do i=1,nres-1 - write (iout,*) i,itype(i),itel(i) - enddo - print *,'Call Read_Bridge.' - endif - call read_bridge -!-------------------------------- -! znamy nres oraz nss można zaalokowac potrzebne tablice - call alloc_geo_arrays - call alloc_ener_arrays -!-------------------------------- -! 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - allocate(idih_constr(ndih_constr),idih_nconstr(ndih_constr)) !(maxdih_constr) - allocate(phi0(ndih_constr),drange(ndih_constr)) !(maxdih_constr) - read (inp,*) ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - if(me.eq.king.or..not.out1file)then - write (iout,*) & - 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - endif - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - if(me.eq.king.or..not.out1file) & - write (iout,*) 'FTORS',ftors - do i=1,ndih_constr - ii = idih_constr(i) - phibound(1,ii) = phi0(i)-drange(i) - phibound(2,ii) = phi0(i)+drange(i) - enddo - endif - nnt=1 -#ifdef MPI - if (me.eq.king) then -#endif - write (iout,'(a)') 'Boundaries in phi angle sampling:' - do i=1,nres - write (iout,'(a3,i5,2f10.1)') & - restyp(itype(i)),i,phibound(1,i)*rad2deg,phibound(2,i)*rad2deg - enddo -#ifdef MP - endif -#endif - nct=nres -!d print *,'NNT=',NNT,' NCT=',NCT - if (itype(1).eq.ntyp1) nnt=2 - if (itype(nres).eq.ntyp1) nct=nct-1 - if (pdbref) then - if(me.eq.king.or..not.out1file) & - write (iout,'(a,i3)') 'nsup=',nsup - nstart_seq=nnt - if (nsup.le.(nct-nnt+1)) then - do i=0,nct-nnt+1-nsup - if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then - nstart_seq=nnt+i - goto 111 - endif - enddo - write (iout,'(a)') & - 'Error - sequences to be superposed do not match.' - stop - else - do i=0,nsup-(nct-nnt+1) - if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) & - then - nstart_sup=nstart_sup+i - nsup=nct-nnt+1 - goto 111 - endif - enddo - write (iout,'(a)') & - 'Error - sequences to be superposed do not match.' - endif - 111 continue - if (nsup.eq.0) nsup=nct-nnt - if (nstart_sup.eq.0) nstart_sup=nnt - if (nstart_seq.eq.0) nstart_seq=nnt - if(me.eq.king.or..not.out1file) & - write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup,& - ' nstart_seq=',nstart_seq !,"242343453254" - endif -!--- Zscore rms ------- - if (nz_start.eq.0) nz_start=nnt - if (nz_end.eq.0 .and. nsup.gt.0) then - nz_end=nnt+nsup-1 - else if (nz_end.eq.0) then - nz_end=nct - endif - if(me.eq.king.or..not.out1file)then - write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end - write (iout,*) 'IZ_SC=',iz_sc - endif -!---------------------- - call init_int_table - if (refstr) then - if (.not.pdbref) then - call read_angles(inp,*38) - goto 39 - 38 write (iout,'(a)') 'Error reading reference structure.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) - stop 'Error reading reference structure' -#endif - 39 call chainbuild - call setup_var -!zscore call geom_to_var(nvar,coord_exp_zs(1,1)) - nstart_sup=nnt - nstart_seq=nnt - nsup=nct-nnt+1 - kkk=1 - do i=1,2*nres - do j=1,3 - cref(j,i,kkk)=c(j,i) - enddo - enddo - call contact(.true.,ncont_ref,icont_ref,co) - endif -! write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup - call flush(iout) - if (constr_dist.gt.0) call read_dist_constr - write (iout,*) "After read_dist_constr nhpb",nhpb - call hpb_partition - if(me.eq.king.or..not.out1file) & - write (iout,*) 'Contact order:',co - if (pdbref) then - if(me.eq.king.or..not.out1file) & - write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup - do i=1,ncont_ref - do j=1,2 - icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup - enddo - if(me.eq.king.or..not.out1file) & - write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ',& - icont_ref(1,i),' ',& - restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i) - enddo - endif - endif - if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4 & - .and. modecalc.ne.8 .and. modecalc.ne.9 .and. & - modecalc.ne.10) then -! If input structure hasn't been supplied from the PDB file read or generate -! initial geometry. - if (iranconf.eq.0 .and. .not. extconf) then - if(me.eq.king.or..not.out1file .and.fg_rank.eq.0) & - write (iout,'(a)') 'Initial geometry will be read in.' - if (read_cart) then - read(inp,'(8f10.5)',end=36,err=36) & - ((c(l,k),l=1,3),k=1,nres),& - ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "Exit READ_CART" - write (iout,'(8f10.5)') & - ((c(l,k),l=1,3),k=1,nres),& - ((c(l,k+nres),l=1,3),k=nnt,nct) - call int_from_cart1(.true.) - write (iout,*) "Finish INT_TO_CART" - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - return - else - call read_angles(inp,*36) - endif - goto 37 - 36 write (iout,'(a)') 'Error reading angle file.' -#ifdef MPI - call mpi_finalize( MPI_COMM_WORLD,IERR ) -#endif - stop 'Error reading angle file.' - 37 continue - else if (extconf) then - if(me.eq.king.or..not.out1file .and. fg_rank.eq.0) & - write (iout,'(a)') 'Extended chain initial geometry.' - do i=3,nres - theta(i)=90d0*deg2rad - enddo - do i=4,nres - phi(i)=180d0*deg2rad - enddo - do i=2,nres-1 - alph(i)=110d0*deg2rad - enddo -!elwrite (iout,*)"alph(i)*deg2rad",(alph(i), i=1,nres) - do i=2,nres-1 - omeg(i)=-120d0*deg2rad - if (itype(i).le.0) omeg(i)=-omeg(i) - enddo - else - if(me.eq.king.or..not.out1file) & - write (iout,'(a)') 'Random-generated initial geometry.' - - -#ifdef MPI - if (me.eq.king .or. fg_rank.eq.0 .and. & - ( modecalc.eq.12 .or. modecalc.eq.14) ) then -#endif - do itrial=1,100 - itmp=1 - call gen_rand_conf(itmp,*30) - goto 40 - 30 write (iout,*) 'Failed to generate random conformation',& - ', itrial=',itrial - write (*,*) 'Processor:',me,& - ' Failed to generate random conformation',& - ' itrial=',itrial - call intout - -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - enddo - write (iout,'(a,i3,a)') 'Processor:',me,& - ' error in generating random conformation.' - write (*,'(a,i3,a)') 'Processor:',me,& - ' error in generating random conformation.' - call flush(iout) -#ifdef MPI - call MPI_Abort(mpi_comm_world,error_msg,ierrcode) - 40 continue - endif -#else - do itrial=1,100 - itmp=1 - call gen_rand_conf(itmp,*335) - goto 40 - 335 write (iout,*) 'Failed to generate random conformation',& - ', itrial=',itrial - write (*,*) 'Failed to generate random conformation',& - ', itrial=',itrial - enddo - write (iout,'(a,i3,a)') 'Processor:',me,& - ' error in generating random conformation.' - write (*,'(a,i3,a)') 'Processor:',me,& - ' error in generating random conformation.' - stop - 40 continue -#endif - endif - elseif (modecalc.eq.4) then - read (inp,'(a)') intinname - open (intin,file=intinname,status='old',err=333) - if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0) & - write (iout,'(a)') 'intinname',intinname - write (*,'(a)') 'Processor',myrank,' intinname',intinname - goto 334 - 333 write (iout,'(2a)') 'Error opening angle file ',intinname -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERR) -#endif - stop 'Error opening angle file.' - 334 continue - - endif -! Generate distance constraints, if the PDB structure is to be regularized. - if (nthread.gt.0) then - call read_threadbase - endif - call setup_var -!elwrite (iout,*)"alph(i)*deg2rad",(alph(i), i=1,nres) - if (me.eq.king .or. .not. out1file) & - call intout -!elwrite (iout,*)"alph(i)*rad2deg",(alph(i)*rad2deg, i=1,nres) - if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then - write (iout,'(/a,i3,a)') & - 'The chain contains',ns,' disulfide-bridging cysteines.' - write (iout,'(20i4)') (iss(i),i=1,ns) - if (dyn_ss) then - write(iout,*)"Running with dynamic disulfide-bond formation" - else - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - if (me.eq.king.or..not.out1file) & - write (iout,'(2a,i3,3a,i3,a,3f10.3)') & - restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i),& - ebr,forcon(i) - enddo - write (iout,'(a)') - endif - endif - if (ns.gt.0.and.dyn_ss) then - do i=nss+1,nhpb - ihpb(i-nss)=ihpb(i) - jhpb(i-nss)=jhpb(i) - forcon(i-nss)=forcon(i) - dhpb(i-nss)=dhpb(i) - enddo - nhpb=nhpb-nss - nss=0 - call hpb_partition - do i=1,ns - dyn_ss_mask(iss(i))=.true. - enddo - endif - if (i2ndstr.gt.0) call secstrp2dihc -! call geom_to_var(nvar,x) -! call etotal(energia(0)) -! call enerprint(energia(0)) -! call briefout(0,etot) -! stop -!d write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT -!d write (iout,'(a)') 'Variable list:' -!d write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar) -#ifdef MPI - if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file)) & - write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)') & - 'Processor',myrank,': end reading molecular data.' -#endif - return - end subroutine molread -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module io diff --git a/source/unres/io_base.F90 b/source/unres/io_base.F90 new file mode 100644 index 0000000..f86b4dd --- /dev/null +++ b/source/unres/io_base.F90 @@ -0,0 +1,1326 @@ + module io_base +!----------------------------------------------------------------------- + use names + use io_units + implicit none +!----------------------------------------------------------------------------- +! Max. number of AA residues + integer,parameter :: maxres=6000!1200 +! Appr. max. number of interaction sites + integer,parameter :: maxres2=2*maxres +! parameter (maxres6=6*maxres) +! parameter (mmaxres2=(maxres2*(maxres2+1)/2)) +!----------------------------------------------------------------------------- +! Max. number of S-S bridges +! integer,parameter :: maxss=20 +!----------------------------------------------------------------------------- +! Max. number of derivatives of virtual-bond and side-chain vectors in theta +! or phi. +! integer,parameter :: maxdim=(maxres-1)*(maxres-2)/2 +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + subroutine read_bridge +! Read information about disulfide bridges. + use geometry_data, only: nres + use energy_data + use control_data, only:out1file + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.LOCAL' +! include 'COMMON.NAMES' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' +! include 'COMMON.DBASE' +! include 'COMMON.THREAD' +! include 'COMMON.TIME1' +! include 'COMMON.SETUP' +!el local variables + integer :: i,j,ierror + +! Read bridging residues. + read (inp,*) ns + if (ns.gt.0) then + allocate(iss(ns)) + read (inp,*) (iss(i),i=1,ns) + endif + +! print *,'ns=',ns + if(me.eq.king.or..not.out1file) & + write (iout,*) 'ns=',ns + if (ns.gt.0) & + write(iout,*) ' iss:',(iss(i),i=1,ns) +! Check whether the specified bridging residues are cystines. + do i=1,ns + if (itype(iss(i)).ne.1) then + if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)') & + 'Do you REALLY think that the residue ',& + restyp(itype(iss(i))),i,& + ' can form a disulfide bridge?!!!' + write (*,'(2a,i3,a)') & + 'Do you REALLY think that the residue ',& + restyp(itype(iss(i))),i,& + ' can form a disulfide bridge?!!!' +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,ierror) + stop +#endif + endif + enddo +! Read preformed bridges. + if (ns.gt.0) then + read (inp,*) nss + if (nss.gt.0) then + if(.not.allocated(ihpb)) allocate(ihpb(nss)) + if(.not.allocated(jhpb)) allocate(jhpb(nss)) + read (inp,*) (ihpb(i),jhpb(i),i=1,nss) + + if(.not.allocated(dhpb)) allocate(dhpb(nss)) + if(.not.allocated(forcon)) allocate(forcon(nss))!(maxdim) !el maxdim=(maxres-1)*(maxres-2)/2 + if(.not.allocated(dhpb1)) allocate(dhpb1(nss)) + if(.not.allocated(ibecarb)) allocate(ibecarb(nss)) +! el Initialize the bridge array + do i=1,nss + dhpb(i)=0.0D0 + enddo + endif +!-------------------- + if(fg_rank.eq.0) & + write(iout,*)'nss=',nss !el,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) + if (nss.gt.0) then + write(iout,*)'ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) + nhpb=nss +! Check if the residues involved in bridges are in the specified list of +! bridging residues. + do i=1,nss + do j=1,i-1 + if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) & + .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then + write (iout,'(a,i3,a)') 'Disulfide pair',i,& + ' contains residues present in other pairs.' + write (*,'(a,i3,a)') 'Disulfide pair',i,& + ' contains residues present in other pairs.' +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,ierror) + stop +#endif + endif + enddo + do j=1,ns + if (ihpb(i).eq.iss(j)) goto 10 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 10 continue + do j=1,ns + if (jhpb(i).eq.iss(j)) goto 20 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 20 continue + dhpb(i)=d0cm + forcon(i)=akcm + enddo + do i=1,nss + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + enddo + endif + endif +! write(iout,*) "end read_bridge" + return + end subroutine read_bridge +!----------------------------------------------------------------------------- + subroutine read_x(kanal,*) + + use geometry_data + use energy_data + use geometry, only:int_from_cart1 +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! Read coordinates from input +! +!el local variables + integer :: l,k,j,i,kanal + + read(kanal,'(8f10.5)',end=10,err=10) & + ((c(l,k),l=1,3),k=1,nres),& + ((c(l,k+nres),l=1,3),k=nnt,nct) + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + call int_from_cart1(.false.) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + endif + enddo + + return + 10 return 1 + end subroutine read_x +!----------------------------------------------------------------------------- + subroutine read_threadbase + + use geometry_data + use energy_data + use compare_data +! 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' + +!el local variables + integer :: k,j,i + +! Read pattern database for threading. + read (icbase,*) nseq + allocate(cart_base(3,maxres_base,nseq)) !(3,maxres_base,maxseq) + allocate(nres_base(3,nseq)) !(3,maxseq) + allocate(str_nam(nseq)) !(maxseq) + do i=1,nseq + read (icbase,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i),& + nres_base(2,i),nres_base(3,i) + read (icbase,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1,& + nres_base(1,i)) +! write (iout,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), +! & nres_base(2,i),nres_base(3,i) +! write (iout,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, +! & nres_base(1,i)) + enddo + close (icbase) + if (weidis.eq.0.0D0) weidis=0.1D0 + do i=nnt,nct + do j=i+2,nct + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=weidis + enddo + enddo + read (inp,*) nexcl,(iexam(1,i),iexam(2,i),i=1,nexcl) + write (iout,'(a,i5)') 'nexcl: ',nexcl + write (iout,'(2i5)') (iexam(1,i),iexam(2,i),i=1,nexcl) + return + end subroutine read_threadbase +!----------------------------------------------------------------------------- +#ifdef WHAM_RUN +!el subroutine read_angles(kanal,iscor,energ,iprot,*) + subroutine read_angles(kanal,*) + + use geometry_data + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'COMMON.INTERACT' +! include 'COMMON.SBRIDGE' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' + character(len=80) :: lineh + integer :: iscor,iprot,ic + real(kind=8) :: energ +#else + subroutine read_angles(kanal,*) + + use geometry_data + ! use energy + ! use control +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTROL' +#endif +! Read angles from input +! +!el local variables + integer :: i,kanal +#ifdef WHAM_RUN + read(kanal,'(a80)',end=10,err=10) lineh + read(lineh(:5),*,err=8) ic + read(lineh(6:),*,err=8) energ + goto 9 + 8 ic=1 + print *,'error, assuming e=1d10',lineh + energ=1d10 + nss=0 + 9 continue + read(lineh(18:),*,end=10,err=10) nss + IF (NSS.LT.9) THEN + read (lineh(20:),*,end=10,err=10) & + (IHPB(I),JHPB(I),I=1,NSS),iscor + ELSE + read (lineh(20:),*,end=10,err=10) (IHPB(I),JHPB(I),I=1,8) + read (kanal,*,end=10,err=10) (IHPB(I),JHPB(I),& + I=9,NSS),iscor + ENDIF +! print *,"energy",energ," iscor",iscor +#endif + read (kanal,*,err=10,end=10) (theta(i),i=3,nres) + read (kanal,*,err=10,end=10) (phi(i),i=4,nres) + read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) + read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) + + do i=1,nres +! 9/7/01 avoid 180 deg valence angle + if (theta(i).gt.179.99d0) theta(i)=179.99d0 +! + theta(i)=deg2rad*theta(i) + phi(i)=deg2rad*phi(i) + alph(i)=deg2rad*alph(i) + omeg(i)=deg2rad*omeg(i) + enddo + return + 10 return 1 + end subroutine read_angles +!----------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + +! implicit none + character*(*) :: rekord,lancuch + real(kind=8) :: wartosc,default + integer :: iread !,ilen +!el external ilen + iread=index(rekord,lancuch) + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,err=10,end=10) wartosc + return + 10 wartosc=default + return + end subroutine reada +!----------------------------------------------------------------------------- + subroutine readi(rekord,lancuch,wartosc,default) + +! implicit none + character*(*) :: rekord,lancuch + integer :: wartosc,default + integer :: iread !,ilen +!el external ilen + iread=index(rekord,lancuch) + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,err=10,end=10) wartosc + return + 10 wartosc=default + return + end subroutine readi +!----------------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + +! implicit none + integer :: dim,i + integer :: tablica(dim),default + character*(*) :: rekord,lancuch + character(len=80) :: aux + integer :: iread !,ilen +!el external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end subroutine multreadi +!----------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + +! implicit none + integer :: dim,i + real(kind=8) :: tablica(dim),default + character*(*) :: rekord,lancuch + character(len=80) :: aux + integer :: iread !,ilen +!el external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end subroutine multreada +!----------------------------------------------------------------------------- + subroutine card_concat(card,to_upper) + +! dla UNRESA to_upper jest zawsze .true. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + character(*) :: card + character(len=80) :: karta !,ucase + logical :: to_upper +!el external ilen + read (inp,'(a)') karta + if (to_upper) karta=ucase(karta) + card=' ' + do while (karta(80:80).eq.'&') + card=card(:ilen(card)+1)//karta(:79) + read (inp,'(a)') karta + if (to_upper) karta=ucase(karta) + enddo + card=card(:ilen(card)+1)//karta + return + end subroutine card_concat +!----------------------------------------------------------------------------- + subroutine read_dist_constr + use MPI_data + ! use control + use geometry, only: dist + use geometry_data + use control_data + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.SBRIDGE' + integer,dimension(2,100) :: ifrag_,ipair_ + real(kind=8),dimension(100) :: wfrag_,wpair_ + character(len=640) :: controlcard + +!el local variables + integer :: i,k,j,ddjk,ii,jj,itemp + integer :: nfrag_,npair_,ndist_ + real(kind=8) :: dist_cut + +! write (iout,*) "Calling read_dist_constr" +! write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +! call flush(iout) + call card_concat(controlcard,.true.) + call readi(controlcard,"NFRAG",nfrag_,0) + call readi(controlcard,"NPAIR",npair_,0) + call readi(controlcard,"NDIST",ndist_,0) + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) + call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) + call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) + call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) + call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) +! write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ +! write (iout,*) "IFRAG" +! do i=1,nfrag_ +! write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) +! enddo +! write (iout,*) "IPAIR" +! do i=1,npair_ +! write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) +! enddo + if(.not.allocated(ihpb)) allocate(ihpb(maxdim)) + if(.not.allocated(jhpb)) allocate(jhpb(maxdim)) + if(.not.allocated(dhpb)) allocate(dhpb(maxdim)) + if(.not.allocated(forcon)) allocate(forcon(maxdim)) + + call flush(iout) + do i=1,nfrag_ + if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup + if (ifrag_(2,i).gt.nstart_sup+nsup-1) & + ifrag_(2,i)=nstart_sup+nsup-1 +! write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) + call flush(iout) + if (wfrag_(i).gt.0.0d0) then + do j=ifrag_(1,i),ifrag_(2,i)-1 + do k=j+1,ifrag_(2,i) +! write (iout,*) "j",j," k",k + ddjk=dist(j,k) + if (constr_dist.eq.1) then + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + else if (constr_dist.eq.2) then + if (ddjk.le.dist_cut) then + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif +#ifdef MPI + if (.not.out1file .or. me.eq.king) & + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",& + nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",& + nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + enddo + enddo + endif + enddo + do i=1,npair_ + if (wpair_(i).gt.0.0d0) then + ii = ipair_(1,i) + jj = ipair_(2,i) + if (ii.gt.jj) then + itemp=ii + ii=jj + jj=itemp + endif + do j=ifrag_(1,ii),ifrag_(2,ii) + do k=ifrag_(1,jj),ifrag_(2,jj) + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + forcon(nhpb)=wpair_(i) + dhpb(nhpb)=dist(j,k) +#ifdef MPI + if (.not.out1file .or. me.eq.king) & + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& + nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& + nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + enddo + enddo + endif + enddo + do i=1,ndist_ + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) +#ifdef MPI + if (.not.out1file .or. me.eq.king) & + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& + nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& + nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + endif + enddo + call flush(iout) + return + end subroutine read_dist_constr +!----------------------------------------------------------------------------- +#ifdef WINIFL + subroutine flush(iu) + return + end subroutine flush +#endif +#ifdef AIX + subroutine flush(iu) + call flush_(iu) + return + end subroutine flush +#endif +!----------------------------------------------------------------------------- + subroutine copy_to_tmp(source) + +! include "DIMENSIONS" +! include "COMMON.IOUNITS" + character*(*) :: source + character(len=256) :: tmpfile +! integer ilen +!el external ilen + logical :: ex + tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source)) + inquire(file=tmpfile,exist=ex) + if (ex) then + write (*,*) "Copying ",tmpfile(:ilen(tmpfile)),& + " to temporary directory..." + write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir + call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir) + endif + return + end subroutine copy_to_tmp +!----------------------------------------------------------------------------- + subroutine move_from_tmp(source) + +! include "DIMENSIONS" +! include "COMMON.IOUNITS" + character*(*) :: source +! integer ilen +!el external ilen + write (*,*) "Moving ",source(:ilen(source)),& + " from temporary directory to working directory" + write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir + call system("/bin/mv "//source(:ilen(source))//" "//curdir) + return + end subroutine move_from_tmp +!----------------------------------------------------------------------------- +! misc.f +!----------------------------------------------------------------------------- +! $Date: 1994/10/12 17:24:21 $ +! $Revision: 2.5 $ + + logical function find_arg(ipos,line,errflag) + + integer, parameter :: maxlen = 80 + character(len=80) :: line + character(len=1) :: empty=' ',equal='=' + logical :: errflag + integer :: ipos +! This function returns .TRUE., if an argument follows keyword keywd; if so +! IPOS will point to the first non-blank character of the argument. Returns +! .FALSE., if no argument follows the keyword; in this case IPOS points +! to the first non-blank character of the next keyword. + + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + errflag=.false. + if (line(ipos:ipos).eq.equal) then + find_arg=.true. + ipos=ipos+1 + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen) errflag=.true. + else + find_arg=.false. + endif + + return + end function find_arg +!----------------------------------------------------------------------------- + logical function find_group(iunit,jout,key1) + + character*(*) :: key1 + character(len=80) :: karta !,ucase + integer :: iunit,jout + integer :: ll !,ilen +!EL external ilen +!EL logical lcom + rewind (iunit) + karta=' ' + ll=ilen(key1) + do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) + read (iunit,'(a)',end=10) karta + enddo + write (jout,'(2a)') '> ',karta(1:78) + find_group=.true. + return + 10 find_group=.false. + return + end function find_group +!----------------------------------------------------------------------------- + logical function iblnk(charc) + character(len=1) :: charc + integer :: n + n = ichar(charc) + iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq.' ') + return + end function iblnk +!----------------------------------------------------------------------------- + integer function ilen(string) + character*(*) :: string +!EL logical :: iblnk + + ilen = len(string) +1 if ( ilen .gt. 0 ) then + if ( iblnk( string(ilen:ilen) ) ) then + ilen = ilen - 1 + goto 1 + endif + endif + return + end function ilen +!----------------------------------------------------------------------------- + integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + integer :: nkey,i,ikey,narg + character(len=16) :: keywd,keywdset(1:nkey,0:nkey) +! character(len=16) :: ucase + + do i=1,narg + if (ucase(keywd).eq.keywdset(i,ikey)) then +! Match found + in_keywd_set=i + return + endif + enddo +! No match to the allowed set of keywords if this point is reached. + in_keywd_set=0 + return + end function in_keywd_set +!----------------------------------------------------------------------------- + character function lcase(string) + integer :: i, k, idiff + character*(*) :: string + character(len=1) :: c + character(len=40) :: chtmp +! + i = len(lcase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + lcase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'A') .and. lle(c,'Z')) then + lcase(i:i) = char(ichar(c) + idiff) + endif + 99 continue + return + end function lcase +!----------------------------------------------------------------------------- + logical function lcom(ipos,karta) + character(len=80) :: karta + character :: koment(2) = (/'!','#'/) + integer :: ipos,i + + lcom=.false. + do i=1,2 + if (karta(ipos:ipos).eq.koment(i)) lcom=.true. + enddo + return + end function lcom +!----------------------------------------------------------------------------- + logical function lower_case(ch) + character*(*) :: ch + lower_case=(ch.ge.'a' .and. ch.le.'z') + return + end function lower_case +!----------------------------------------------------------------------------- + subroutine mykey(line,keywd,ipos,blankline,errflag) + +! This subroutine seeks a non-empty substring keywd in the string LINE. +! The substring begins with the first character different from blank and +! "=" encountered right to the pointer IPOS (inclusively) and terminates +! at the character left to the first blank or "=". When the subroutine is +! exited, the pointer IPOS is moved to the position of the terminator in LINE. +! The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains +! only separators or the maximum length of the data line (80) has been reached. +! The logical variable ERRFLAG is set at .TRUE. if the string +! consists only from a "=". + integer, parameter :: maxlen=80 + character(len=1) :: empty=' ',equal='=',comma=',' + character*(*) :: keywd + character(len=80) :: line + logical :: blankline,errflag !EL,lcom + integer :: ipos,istart,iend + errflag=.false. + do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen .or. lcom(ipos,line) ) then +! At this point the rest of the input line turned out to contain only blanks +! or to be commented out. + blankline=.true. + return + endif + blankline=.false. + istart=ipos +! Checks whether the current char is a separator. + do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal & + .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + iend=ipos-1 +! Error flag set to .true., if the length of the keyword was found less than 1. + if (iend.lt.istart) then + errflag=.true. + return + endif + keywd=line(istart:iend) + return + end subroutine mykey +!----------------------------------------------------------------------------- + subroutine numstr(inum,numm) + character(len=10) :: huj='0123456789' + character*(*) :: numm + integer :: inumm,inum,inum1,inum2 + inumm=inum + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(3:3)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(2:2)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(1:1)=huj(inum2+1:inum2+1) + return + end subroutine numstr +!----------------------------------------------------------------------------- + function ucase(string) + integer :: i, k, idiff + character(*) :: string + character(len=len(string)) :: ucase + character(len=1) :: c + character(len=40) :: chtmp +! + i = len(ucase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + ucase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'a') .and. lle(c,'z')) then + ucase(i:i) = char(ichar(c) - idiff) + endif + 99 continue + return + end function ucase +!----------------------------------------------------------------------------- +! geomout.F +!----------------------------------------------------------------------------- + subroutine pdbout(etot,tytul,iunit) + + use geometry_data, only: c,nres + use energy_data + ! use control + use compare_data + use MD_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' +! include 'COMMON.DISTFIT' +! include 'COMMON.MD' +!el character(len=50) :: tytul + character*(*) :: tytul + character(len=1),dimension(10) :: chainid= (/'A','B','C','D','E','F','G','H','I','J'/) + integer,dimension(nres) :: ica !(maxres) + +!el local variables + integer :: j,iti,itj,itk,itl,i,iatom,ichain,ires,iunit + real(kind=8) :: etot + integer :: nres2 + nres2=2*nres + + if(.not.allocated(vtot)) allocate(vtot(nres2)) !(maxres2) + + write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot +!model write (iunit,'(a5,i6)') 'MODEL',1 + if (nhfrag.gt.0) then + do j=1,nhfrag + iti=itype(hfrag(1,j)) + itj=itype(hfrag(2,j)) + if (j.lt.10) then + write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') & + 'HELIX',j,'H',j,& + restyp(iti),hfrag(1,j)-1,& + restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) + else + write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') & + 'HELIX',j,'H',j,& + restyp(iti),hfrag(1,j)-1,& + restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) + endif + enddo + endif + + if (nbfrag.gt.0) then + + do j=1,nbfrag + + iti=itype(bfrag(1,j)) + itj=itype(bfrag(2,j)-1) + + write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') & + 'SHEET',1,'B',j,2,& + restyp(iti),bfrag(1,j)-1,& + restyp(itj),bfrag(2,j)-2,0 + + if (bfrag(3,j).gt.bfrag(4,j)) then + + itk=itype(bfrag(3,j)) + itl=itype(bfrag(4,j)+1) + + write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') & + 'SHEET',2,'B',j,2,& + restyp(itl),bfrag(4,j),& + restyp(itk),bfrag(3,j)-1,-1,& + "N",restyp(itk),bfrag(3,j)-1,& + "O",restyp(iti),bfrag(1,j)-1 + + else + + itk=itype(bfrag(3,j)) + itl=itype(bfrag(4,j)-1) + + + write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') & + 'SHEET',2,'B',j,2,& + restyp(itk),bfrag(3,j)-1,& + restyp(itl),bfrag(4,j)-2,1,& + "N",restyp(itk),bfrag(3,j)-1,& + "O",restyp(iti),bfrag(1,j)-1 + + + + endif + + enddo + endif + + if (nss.gt.0) then + do i=1,nss + if (dyn_ss) then + write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') & + 'SSBOND',i,'CYS',idssb(i)-nnt+1,& + 'CYS',jdssb(i)-nnt+1 + else + write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') & + 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres,& + 'CYS',jhpb(i)-nnt+1-nres + endif + enddo + endif + + iatom=0 + ichain=1 + ires=0 + do i=nnt,nct + iti=itype(i) + if (iti.eq.ntyp1) then + ichain=ichain+1 + ires=0 + write (iunit,'(a)') 'TER' + else + ires=ires+1 + iatom=iatom+1 + ica(i)=iatom + write (iunit,10) iatom,restyp(iti),chainid(ichain),& + ires,(c(j,i),j=1,3),vtot(i) + if (iti.ne.10) then + iatom=iatom+1 + write (iunit,20) iatom,restyp(iti),chainid(ichain),& + ires,(c(j,nres+i),j=1,3),& + vtot(i+nres) + endif + endif + enddo + write (iunit,'(a)') 'TER' + do i=nnt,nct-1 + if (itype(i).eq.ntyp1) cycle + if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then + write (iunit,30) ica(i),ica(i+1) + else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then + write (iunit,30) ica(i),ica(i+1),ica(i)+1 + else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then + write (iunit,30) ica(i),ica(i)+1 + endif + enddo + if (itype(nct).ne.10) then + write (iunit,30) ica(nct),ica(nct)+1 + endif + do i=1,nss + if (dyn_ss) then + write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1 + else + write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 + endif + enddo + write (iunit,'(a6)') 'ENDMDL' + 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3) + 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,f15.3) + 30 FORMAT ('CONECT',8I5) + return + end subroutine pdbout +!----------------------------------------------------------------------------- + subroutine MOL2out(etot,tytul) +! Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 +! format. + use geometry_data, only: c + use energy_data + ! use control +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' + character(len=32) :: tytul,fd + character(len=3) :: zahl + character(len=6) :: res_num,pom !,ucase + +!el local variables + integer :: i,j + real(kind=8) :: etot + +#ifdef AIX + call fdate_(fd) +#elif (defined CRAY) + call date(fd) +#else + call fdate(fd) +#endif + write (imol2,'(a)') '#' + write (imol2,'(a)') & + '# Creating user name: unres' + write (imol2,'(2a)') '# Creation time: ',& + fd + write (imol2,'(/a)') '\@MOLECULE' + write (imol2,'(a)') tytul + write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 + write (imol2,'(a)') 'SMALL' + write (imol2,'(a)') 'USER_CHARGES' + write (imol2,'(a)') '\@ATOM' + do i=nnt,nct + write (zahl,'(i3)') i + pom=ucase(restyp(itype(i))) + res_num = pom(:3)//zahl(2:) + write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0 + enddo + write (imol2,'(a)') '\@BOND' + do i=nnt,nct-1 + write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 + enddo + do i=1,nss + write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 + enddo + write (imol2,'(a)') '\@SUBSTRUCTURE' + do i=nnt,nct + write (zahl,'(i3)') i + pom = ucase(restyp(itype(i))) + res_num = pom(:3)//zahl(2:) + write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 + enddo + 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') + 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') + return + end subroutine MOL2out +!----------------------------------------------------------------------------- + subroutine intout + + use geometry_data + use energy_data, only: itype + ! use control +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.TORSION' +!el local variables + integer :: i,iti + + write (iout,'(/a)') 'Geometry of the virtual chain.' + write (iout,'(7a)') ' Res ',' d',' Theta',& + ' Phi',' Dsc',' Alpha',' Omega' + do i=1,nres + iti=itype(i) + write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),& + rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),& + rad2deg*omeg(i) + enddo + return + end subroutine intout +!----------------------------------------------------------------------------- +#ifdef CLUSTER + subroutine briefout(it,ener,free)!,plik) +#else + subroutine briefout(it,ener) +#endif + use geometry_data + use energy_data + ! use control +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.SBRIDGE' +! print '(a,i5)',intname,igeom +!el local variables + integer :: i,it + real(kind=8) :: ener,free +! character(len=80) :: plik +! integer :: iii + +#if defined(AIX) || defined(PGI) + open (igeom,file=intname,position='append') +#else + open (igeom,file=intname,access='append') +#endif +#ifdef WHAM_RUN +! iii=igeom + igeom=iout +#endif + IF (NSS.LE.9) THEN +#ifdef CLUSTER + WRITE (igeom,180) IT,ENER,free,NSS,(IHPB(I),JHPB(I),I=1,NSS) + ELSE + WRITE (igeom,180) IT,ENER,free,NSS,(IHPB(I),JHPB(I),I=1,8) +#else + WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) + ELSE + WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) +#endif + WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) + ENDIF +! IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) +! if (nvar.gt.nphi+ntheta) then + write (igeom,200) (rad2deg*alph(i),i=2,nres-1) + write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) +! endif + close(igeom) + 180 format (I5,F12.3,I2,9(1X,2I3)) + 190 format (3X,11(1X,2I3)) + 200 format (8F10.4) + return + end subroutine briefout +!----------------------------------------------------------------------------- +#ifdef WINIFL + subroutine fdate(fd) + character(len=32) :: fd + write(fd,'(32x)') + return + end subroutine fdate +#endif +!----------------------------------------------------------------------------- +#ifdef WHAM_RUN + real(kind=8) function gyrate(jcon) +#else + real(kind=8) function gyrate() +#endif + + use geometry_data, only: c + ! use geometry + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.INTERACT' +! include 'COMMON.CHAIN' + real(kind=8) :: rg + real(kind=8),dimension(3) :: cen +!el local variables + integer :: i,j,jcon + + do j=1,3 + cen(j)=0.0d0 + enddo + + do i=nnt,nct + do j=1,3 + cen(j)=cen(j)+c(j,i) + enddo + enddo + do j=1,3 + cen(j)=cen(j)/dble(nct-nnt+1) + enddo + rg = 0.0d0 + do i = nnt, nct + do j=1,3 + rg = rg + (c(j,i)-cen(j))**2 + enddo + end do +#ifdef WHAM_RUN + gyrate = dsqrt(rg/dble(nct-nnt+1)) +#else + gyrate = sqrt(rg/dble(nct-nnt+1)) +#endif + return + end function gyrate +#ifdef WHAM_RUN +!----------------------------------------------------------------------------- +! readrtns.F WHAM + subroutine reads(rekord,lancuch,wartosc,default) +! implicit none + character*(*) :: rekord,lancuch,wartosc,default + character(len=80) :: aux + integer :: lenlan,lenrec,iread,ireade +!el external ilen +!el logical iblnk +!el external iblnk + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +! print *,"rekord",rekord," lancuch",lancuch +! print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+lenlan+1 +! print *,"iread",iread +! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +! print *,"iread",iread + if (iread.gt.lenrec) then + wartosc=default + return + endif + ireade=iread+1 +! print *,"ireade",ireade + do while (ireade.lt.lenrec .and. & + .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + wartosc=rekord(iread:ireade) + return + end subroutine reads +#endif +!----------------------------------------------------------------------------- +! permut.F +!----------------------------------------------------------------------------- + subroutine permut(isym) + + use geometry_data, only: tabperm +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.NAMES' +! include 'COMMON.CONTROL' + + integer :: n,isym +! logical nextp +!el external nextp + integer,dimension(isym) :: a +! parameter(n=symetr) +!el local variables + integer :: kkk,i + + n=isym + if (n.eq.1) then + tabperm(1,1)=1 + return + endif + kkk=0 + do i=1,n + a(i)=i + enddo + 10 print *,(a(i),i=1,n) + kkk=kkk+1 + do i=1,n + tabperm(kkk,i)=a(i) +! write (iout,*) "tututu", kkk + enddo + if(nextp(n,a)) go to 10 + return + end subroutine permut +!----------------------------------------------------------------------------- + logical function nextp(n,a) + + integer :: n,i,j,k,t +! logical :: nextp + integer,dimension(n) :: a + i=n-1 + 10 if(a(i).lt.a(i+1)) go to 20 + i=i-1 + if(i.eq.0) go to 20 + go to 10 + 20 j=i+1 + k=n + 30 t=a(j) + a(j)=a(k) + a(k)=t + j=j+1 + k=k-1 + if(j.lt.k) go to 30 + j=i + if(j.ne.0) go to 40 + nextp=.false. + return + 40 j=j+1 + if(a(j).lt.a(i)) go to 40 + t=a(i) + a(i)=a(j) + a(j)=t + nextp=.true. + return + end function nextp +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module io_base diff --git a/source/unres/io_base.f90 b/source/unres/io_base.f90 deleted file mode 100644 index f86b4dd..0000000 --- a/source/unres/io_base.f90 +++ /dev/null @@ -1,1326 +0,0 @@ - module io_base -!----------------------------------------------------------------------- - use names - use io_units - implicit none -!----------------------------------------------------------------------------- -! Max. number of AA residues - integer,parameter :: maxres=6000!1200 -! Appr. max. number of interaction sites - integer,parameter :: maxres2=2*maxres -! parameter (maxres6=6*maxres) -! parameter (mmaxres2=(maxres2*(maxres2+1)/2)) -!----------------------------------------------------------------------------- -! Max. number of S-S bridges -! integer,parameter :: maxss=20 -!----------------------------------------------------------------------------- -! Max. number of derivatives of virtual-bond and side-chain vectors in theta -! or phi. -! integer,parameter :: maxdim=(maxres-1)*(maxres-2)/2 -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - subroutine read_bridge -! Read information about disulfide bridges. - use geometry_data, only: nres - use energy_data - use control_data, only:out1file - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.LOCAL' -! include 'COMMON.NAMES' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' -! include 'COMMON.DBASE' -! include 'COMMON.THREAD' -! include 'COMMON.TIME1' -! include 'COMMON.SETUP' -!el local variables - integer :: i,j,ierror - -! Read bridging residues. - read (inp,*) ns - if (ns.gt.0) then - allocate(iss(ns)) - read (inp,*) (iss(i),i=1,ns) - endif - -! print *,'ns=',ns - if(me.eq.king.or..not.out1file) & - write (iout,*) 'ns=',ns - if (ns.gt.0) & - write(iout,*) ' iss:',(iss(i),i=1,ns) -! Check whether the specified bridging residues are cystines. - do i=1,ns - if (itype(iss(i)).ne.1) then - if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)') & - 'Do you REALLY think that the residue ',& - restyp(itype(iss(i))),i,& - ' can form a disulfide bridge?!!!' - write (*,'(2a,i3,a)') & - 'Do you REALLY think that the residue ',& - restyp(itype(iss(i))),i,& - ' can form a disulfide bridge?!!!' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo -! Read preformed bridges. - if (ns.gt.0) then - read (inp,*) nss - if (nss.gt.0) then - if(.not.allocated(ihpb)) allocate(ihpb(nss)) - if(.not.allocated(jhpb)) allocate(jhpb(nss)) - read (inp,*) (ihpb(i),jhpb(i),i=1,nss) - - if(.not.allocated(dhpb)) allocate(dhpb(nss)) - if(.not.allocated(forcon)) allocate(forcon(nss))!(maxdim) !el maxdim=(maxres-1)*(maxres-2)/2 - if(.not.allocated(dhpb1)) allocate(dhpb1(nss)) - if(.not.allocated(ibecarb)) allocate(ibecarb(nss)) -! el Initialize the bridge array - do i=1,nss - dhpb(i)=0.0D0 - enddo - endif -!-------------------- - if(fg_rank.eq.0) & - write(iout,*)'nss=',nss !el,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) - if (nss.gt.0) then - write(iout,*)'ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) - nhpb=nss -! Check if the residues involved in bridges are in the specified list of -! bridging residues. - do i=1,nss - do j=1,i-1 - if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) & - .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then - write (iout,'(a,i3,a)') 'Disulfide pair',i,& - ' contains residues present in other pairs.' - write (*,'(a,i3,a)') 'Disulfide pair',i,& - ' contains residues present in other pairs.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo - do j=1,ns - if (ihpb(i).eq.iss(j)) goto 10 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 10 continue - do j=1,ns - if (jhpb(i).eq.iss(j)) goto 20 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 20 continue - dhpb(i)=d0cm - forcon(i)=akcm - enddo - do i=1,nss - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - enddo - endif - endif -! write(iout,*) "end read_bridge" - return - end subroutine read_bridge -!----------------------------------------------------------------------------- - subroutine read_x(kanal,*) - - use geometry_data - use energy_data - use geometry, only:int_from_cart1 -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! Read coordinates from input -! -!el local variables - integer :: l,k,j,i,kanal - - read(kanal,'(8f10.5)',end=10,err=10) & - ((c(l,k),l=1,3),k=1,nres),& - ((c(l,k+nres),l=1,3),k=nnt,nct) - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - call int_from_cart1(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - - return - 10 return 1 - end subroutine read_x -!----------------------------------------------------------------------------- - subroutine read_threadbase - - use geometry_data - use energy_data - use compare_data -! 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' - -!el local variables - integer :: k,j,i - -! Read pattern database for threading. - read (icbase,*) nseq - allocate(cart_base(3,maxres_base,nseq)) !(3,maxres_base,maxseq) - allocate(nres_base(3,nseq)) !(3,maxseq) - allocate(str_nam(nseq)) !(maxseq) - do i=1,nseq - read (icbase,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i),& - nres_base(2,i),nres_base(3,i) - read (icbase,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1,& - nres_base(1,i)) -! write (iout,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), -! & nres_base(2,i),nres_base(3,i) -! write (iout,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, -! & nres_base(1,i)) - enddo - close (icbase) - if (weidis.eq.0.0D0) weidis=0.1D0 - do i=nnt,nct - do j=i+2,nct - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=weidis - enddo - enddo - read (inp,*) nexcl,(iexam(1,i),iexam(2,i),i=1,nexcl) - write (iout,'(a,i5)') 'nexcl: ',nexcl - write (iout,'(2i5)') (iexam(1,i),iexam(2,i),i=1,nexcl) - return - end subroutine read_threadbase -!----------------------------------------------------------------------------- -#ifdef WHAM_RUN -!el subroutine read_angles(kanal,iscor,energ,iprot,*) - subroutine read_angles(kanal,*) - - use geometry_data - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' - character(len=80) :: lineh - integer :: iscor,iprot,ic - real(kind=8) :: energ -#else - subroutine read_angles(kanal,*) - - use geometry_data - ! use energy - ! use control -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTROL' -#endif -! Read angles from input -! -!el local variables - integer :: i,kanal -#ifdef WHAM_RUN - read(kanal,'(a80)',end=10,err=10) lineh - read(lineh(:5),*,err=8) ic - read(lineh(6:),*,err=8) energ - goto 9 - 8 ic=1 - print *,'error, assuming e=1d10',lineh - energ=1d10 - nss=0 - 9 continue - read(lineh(18:),*,end=10,err=10) nss - IF (NSS.LT.9) THEN - read (lineh(20:),*,end=10,err=10) & - (IHPB(I),JHPB(I),I=1,NSS),iscor - ELSE - read (lineh(20:),*,end=10,err=10) (IHPB(I),JHPB(I),I=1,8) - read (kanal,*,end=10,err=10) (IHPB(I),JHPB(I),& - I=9,NSS),iscor - ENDIF -! print *,"energy",energ," iscor",iscor -#endif - read (kanal,*,err=10,end=10) (theta(i),i=3,nres) - read (kanal,*,err=10,end=10) (phi(i),i=4,nres) - read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) - read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) - - do i=1,nres -! 9/7/01 avoid 180 deg valence angle - if (theta(i).gt.179.99d0) theta(i)=179.99d0 -! - theta(i)=deg2rad*theta(i) - phi(i)=deg2rad*phi(i) - alph(i)=deg2rad*alph(i) - omeg(i)=deg2rad*omeg(i) - enddo - return - 10 return 1 - end subroutine read_angles -!----------------------------------------------------------------------------- - subroutine reada(rekord,lancuch,wartosc,default) - -! implicit none - character*(*) :: rekord,lancuch - real(kind=8) :: wartosc,default - integer :: iread !,ilen -!el external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end subroutine reada -!----------------------------------------------------------------------------- - subroutine readi(rekord,lancuch,wartosc,default) - -! implicit none - character*(*) :: rekord,lancuch - integer :: wartosc,default - integer :: iread !,ilen -!el external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end subroutine readi -!----------------------------------------------------------------------------- - subroutine multreadi(rekord,lancuch,tablica,dim,default) - -! implicit none - integer :: dim,i - integer :: tablica(dim),default - character*(*) :: rekord,lancuch - character(len=80) :: aux - integer :: iread !,ilen -!el external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end subroutine multreadi -!----------------------------------------------------------------------------- - subroutine multreada(rekord,lancuch,tablica,dim,default) - -! implicit none - integer :: dim,i - real(kind=8) :: tablica(dim),default - character*(*) :: rekord,lancuch - character(len=80) :: aux - integer :: iread !,ilen -!el external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end subroutine multreada -!----------------------------------------------------------------------------- - subroutine card_concat(card,to_upper) - -! dla UNRESA to_upper jest zawsze .true. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - character(*) :: card - character(len=80) :: karta !,ucase - logical :: to_upper -!el external ilen - read (inp,'(a)') karta - if (to_upper) karta=ucase(karta) - card=' ' - do while (karta(80:80).eq.'&') - card=card(:ilen(card)+1)//karta(:79) - read (inp,'(a)') karta - if (to_upper) karta=ucase(karta) - enddo - card=card(:ilen(card)+1)//karta - return - end subroutine card_concat -!----------------------------------------------------------------------------- - subroutine read_dist_constr - use MPI_data - ! use control - use geometry, only: dist - use geometry_data - use control_data - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.SBRIDGE' - integer,dimension(2,100) :: ifrag_,ipair_ - real(kind=8),dimension(100) :: wfrag_,wpair_ - character(len=640) :: controlcard - -!el local variables - integer :: i,k,j,ddjk,ii,jj,itemp - integer :: nfrag_,npair_,ndist_ - real(kind=8) :: dist_cut - -! write (iout,*) "Calling read_dist_constr" -! write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup -! call flush(iout) - call card_concat(controlcard,.true.) - call readi(controlcard,"NFRAG",nfrag_,0) - call readi(controlcard,"NPAIR",npair_,0) - call readi(controlcard,"NDIST",ndist_,0) - call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) - call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) - call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) - call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) - call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) -! write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ -! write (iout,*) "IFRAG" -! do i=1,nfrag_ -! write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) -! enddo -! write (iout,*) "IPAIR" -! do i=1,npair_ -! write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) -! enddo - if(.not.allocated(ihpb)) allocate(ihpb(maxdim)) - if(.not.allocated(jhpb)) allocate(jhpb(maxdim)) - if(.not.allocated(dhpb)) allocate(dhpb(maxdim)) - if(.not.allocated(forcon)) allocate(forcon(maxdim)) - - call flush(iout) - do i=1,nfrag_ - if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup - if (ifrag_(2,i).gt.nstart_sup+nsup-1) & - ifrag_(2,i)=nstart_sup+nsup-1 -! write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - call flush(iout) - if (wfrag_(i).gt.0.0d0) then - do j=ifrag_(1,i),ifrag_(2,i)-1 - do k=j+1,ifrag_(2,i) -! write (iout,*) "j",j," k",k - ddjk=dist(j,k) - if (constr_dist.eq.1) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - else if (constr_dist.eq.2) then - if (ddjk.le.dist_cut) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - endif - else - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) - endif -#ifdef MPI - if (.not.out1file .or. me.eq.king) & - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",& - nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",& - nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,npair_ - if (wpair_(i).gt.0.0d0) then - ii = ipair_(1,i) - jj = ipair_(2,i) - if (ii.gt.jj) then - itemp=ii - ii=jj - jj=itemp - endif - do j=ifrag_(1,ii),ifrag_(2,ii) - do k=ifrag_(1,jj),ifrag_(2,jj) - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - forcon(nhpb)=wpair_(i) - dhpb(nhpb)=dist(j,k) -#ifdef MPI - if (.not.out1file .or. me.eq.king) & - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& - nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& - nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,ndist_ - read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) - if (forcon(nhpb+1).gt.0.0d0) then - nhpb=nhpb+1 - dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) -#ifdef MPI - if (.not.out1file .or. me.eq.king) & - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& - nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",& - nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - endif - enddo - call flush(iout) - return - end subroutine read_dist_constr -!----------------------------------------------------------------------------- -#ifdef WINIFL - subroutine flush(iu) - return - end subroutine flush -#endif -#ifdef AIX - subroutine flush(iu) - call flush_(iu) - return - end subroutine flush -#endif -!----------------------------------------------------------------------------- - subroutine copy_to_tmp(source) - -! include "DIMENSIONS" -! include "COMMON.IOUNITS" - character*(*) :: source - character(len=256) :: tmpfile -! integer ilen -!el external ilen - logical :: ex - tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source)) - inquire(file=tmpfile,exist=ex) - if (ex) then - write (*,*) "Copying ",tmpfile(:ilen(tmpfile)),& - " to temporary directory..." - write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir - call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir) - endif - return - end subroutine copy_to_tmp -!----------------------------------------------------------------------------- - subroutine move_from_tmp(source) - -! include "DIMENSIONS" -! include "COMMON.IOUNITS" - character*(*) :: source -! integer ilen -!el external ilen - write (*,*) "Moving ",source(:ilen(source)),& - " from temporary directory to working directory" - write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir - call system("/bin/mv "//source(:ilen(source))//" "//curdir) - return - end subroutine move_from_tmp -!----------------------------------------------------------------------------- -! misc.f -!----------------------------------------------------------------------------- -! $Date: 1994/10/12 17:24:21 $ -! $Revision: 2.5 $ - - logical function find_arg(ipos,line,errflag) - - integer, parameter :: maxlen = 80 - character(len=80) :: line - character(len=1) :: empty=' ',equal='=' - logical :: errflag - integer :: ipos -! This function returns .TRUE., if an argument follows keyword keywd; if so -! IPOS will point to the first non-blank character of the argument. Returns -! .FALSE., if no argument follows the keyword; in this case IPOS points -! to the first non-blank character of the next keyword. - - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - errflag=.false. - if (line(ipos:ipos).eq.equal) then - find_arg=.true. - ipos=ipos+1 - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen) errflag=.true. - else - find_arg=.false. - endif - - return - end function find_arg -!----------------------------------------------------------------------------- - logical function find_group(iunit,jout,key1) - - character*(*) :: key1 - character(len=80) :: karta !,ucase - integer :: iunit,jout - integer :: ll !,ilen -!EL external ilen -!EL logical lcom - rewind (iunit) - karta=' ' - ll=ilen(key1) - do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) - read (iunit,'(a)',end=10) karta - enddo - write (jout,'(2a)') '> ',karta(1:78) - find_group=.true. - return - 10 find_group=.false. - return - end function find_group -!----------------------------------------------------------------------------- - logical function iblnk(charc) - character(len=1) :: charc - integer :: n - n = ichar(charc) - iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq.' ') - return - end function iblnk -!----------------------------------------------------------------------------- - integer function ilen(string) - character*(*) :: string -!EL logical :: iblnk - - ilen = len(string) -1 if ( ilen .gt. 0 ) then - if ( iblnk( string(ilen:ilen) ) ) then - ilen = ilen - 1 - goto 1 - endif - endif - return - end function ilen -!----------------------------------------------------------------------------- - integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) - integer :: nkey,i,ikey,narg - character(len=16) :: keywd,keywdset(1:nkey,0:nkey) -! character(len=16) :: ucase - - do i=1,narg - if (ucase(keywd).eq.keywdset(i,ikey)) then -! Match found - in_keywd_set=i - return - endif - enddo -! No match to the allowed set of keywords if this point is reached. - in_keywd_set=0 - return - end function in_keywd_set -!----------------------------------------------------------------------------- - character function lcase(string) - integer :: i, k, idiff - character*(*) :: string - character(len=1) :: c - character(len=40) :: chtmp -! - i = len(lcase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - lcase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'A') .and. lle(c,'Z')) then - lcase(i:i) = char(ichar(c) + idiff) - endif - 99 continue - return - end function lcase -!----------------------------------------------------------------------------- - logical function lcom(ipos,karta) - character(len=80) :: karta - character :: koment(2) = (/'!','#'/) - integer :: ipos,i - - lcom=.false. - do i=1,2 - if (karta(ipos:ipos).eq.koment(i)) lcom=.true. - enddo - return - end function lcom -!----------------------------------------------------------------------------- - logical function lower_case(ch) - character*(*) :: ch - lower_case=(ch.ge.'a' .and. ch.le.'z') - return - end function lower_case -!----------------------------------------------------------------------------- - subroutine mykey(line,keywd,ipos,blankline,errflag) - -! This subroutine seeks a non-empty substring keywd in the string LINE. -! The substring begins with the first character different from blank and -! "=" encountered right to the pointer IPOS (inclusively) and terminates -! at the character left to the first blank or "=". When the subroutine is -! exited, the pointer IPOS is moved to the position of the terminator in LINE. -! The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains -! only separators or the maximum length of the data line (80) has been reached. -! The logical variable ERRFLAG is set at .TRUE. if the string -! consists only from a "=". - integer, parameter :: maxlen=80 - character(len=1) :: empty=' ',equal='=',comma=',' - character*(*) :: keywd - character(len=80) :: line - logical :: blankline,errflag !EL,lcom - integer :: ipos,istart,iend - errflag=.false. - do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen .or. lcom(ipos,line) ) then -! At this point the rest of the input line turned out to contain only blanks -! or to be commented out. - blankline=.true. - return - endif - blankline=.false. - istart=ipos -! Checks whether the current char is a separator. - do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal & - .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - iend=ipos-1 -! Error flag set to .true., if the length of the keyword was found less than 1. - if (iend.lt.istart) then - errflag=.true. - return - endif - keywd=line(istart:iend) - return - end subroutine mykey -!----------------------------------------------------------------------------- - subroutine numstr(inum,numm) - character(len=10) :: huj='0123456789' - character*(*) :: numm - integer :: inumm,inum,inum1,inum2 - inumm=inum - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(3:3)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(2:2)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(1:1)=huj(inum2+1:inum2+1) - return - end subroutine numstr -!----------------------------------------------------------------------------- - function ucase(string) - integer :: i, k, idiff - character(*) :: string - character(len=len(string)) :: ucase - character(len=1) :: c - character(len=40) :: chtmp -! - i = len(ucase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - ucase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'a') .and. lle(c,'z')) then - ucase(i:i) = char(ichar(c) - idiff) - endif - 99 continue - return - end function ucase -!----------------------------------------------------------------------------- -! geomout.F -!----------------------------------------------------------------------------- - subroutine pdbout(etot,tytul,iunit) - - use geometry_data, only: c,nres - use energy_data - ! use control - use compare_data - use MD_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' -! include 'COMMON.DISTFIT' -! include 'COMMON.MD' -!el character(len=50) :: tytul - character*(*) :: tytul - character(len=1),dimension(10) :: chainid= (/'A','B','C','D','E','F','G','H','I','J'/) - integer,dimension(nres) :: ica !(maxres) - -!el local variables - integer :: j,iti,itj,itk,itl,i,iatom,ichain,ires,iunit - real(kind=8) :: etot - integer :: nres2 - nres2=2*nres - - if(.not.allocated(vtot)) allocate(vtot(nres2)) !(maxres2) - - write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot -!model write (iunit,'(a5,i6)') 'MODEL',1 - if (nhfrag.gt.0) then - do j=1,nhfrag - iti=itype(hfrag(1,j)) - itj=itype(hfrag(2,j)) - if (j.lt.10) then - write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') & - 'HELIX',j,'H',j,& - restyp(iti),hfrag(1,j)-1,& - restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - else - write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') & - 'HELIX',j,'H',j,& - restyp(iti),hfrag(1,j)-1,& - restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - endif - enddo - endif - - if (nbfrag.gt.0) then - - do j=1,nbfrag - - iti=itype(bfrag(1,j)) - itj=itype(bfrag(2,j)-1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') & - 'SHEET',1,'B',j,2,& - restyp(iti),bfrag(1,j)-1,& - restyp(itj),bfrag(2,j)-2,0 - - if (bfrag(3,j).gt.bfrag(4,j)) then - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)+1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') & - 'SHEET',2,'B',j,2,& - restyp(itl),bfrag(4,j),& - restyp(itk),bfrag(3,j)-1,-1,& - "N",restyp(itk),bfrag(3,j)-1,& - "O",restyp(iti),bfrag(1,j)-1 - - else - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)-1) - - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') & - 'SHEET',2,'B',j,2,& - restyp(itk),bfrag(3,j)-1,& - restyp(itl),bfrag(4,j)-2,1,& - "N",restyp(itk),bfrag(3,j)-1,& - "O",restyp(iti),bfrag(1,j)-1 - - - - endif - - enddo - endif - - if (nss.gt.0) then - do i=1,nss - if (dyn_ss) then - write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') & - 'SSBOND',i,'CYS',idssb(i)-nnt+1,& - 'CYS',jdssb(i)-nnt+1 - else - write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') & - 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres,& - 'CYS',jhpb(i)-nnt+1-nres - endif - enddo - endif - - iatom=0 - ichain=1 - ires=0 - do i=nnt,nct - iti=itype(i) - if (iti.eq.ntyp1) then - ichain=ichain+1 - ires=0 - write (iunit,'(a)') 'TER' - else - ires=ires+1 - iatom=iatom+1 - ica(i)=iatom - write (iunit,10) iatom,restyp(iti),chainid(ichain),& - ires,(c(j,i),j=1,3),vtot(i) - if (iti.ne.10) then - iatom=iatom+1 - write (iunit,20) iatom,restyp(iti),chainid(ichain),& - ires,(c(j,nres+i),j=1,3),& - vtot(i+nres) - endif - endif - enddo - write (iunit,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.ntyp1) cycle - if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then - write (iunit,30) ica(i),ica(i+1) - else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then - write (iunit,30) ica(i),ica(i+1),ica(i)+1 - else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then - write (iunit,30) ica(i),ica(i)+1 - endif - enddo - if (itype(nct).ne.10) then - write (iunit,30) ica(nct),ica(nct)+1 - endif - do i=1,nss - if (dyn_ss) then - write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1 - else - write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 - endif - enddo - write (iunit,'(a6)') 'ENDMDL' - 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,f15.3) - 30 FORMAT ('CONECT',8I5) - return - end subroutine pdbout -!----------------------------------------------------------------------------- - subroutine MOL2out(etot,tytul) -! Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 -! format. - use geometry_data, only: c - use energy_data - ! use control -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' - character(len=32) :: tytul,fd - character(len=3) :: zahl - character(len=6) :: res_num,pom !,ucase - -!el local variables - integer :: i,j - real(kind=8) :: etot - -#ifdef AIX - call fdate_(fd) -#elif (defined CRAY) - call date(fd) -#else - call fdate(fd) -#endif - write (imol2,'(a)') '#' - write (imol2,'(a)') & - '# Creating user name: unres' - write (imol2,'(2a)') '# Creation time: ',& - fd - write (imol2,'(/a)') '\@MOLECULE' - write (imol2,'(a)') tytul - write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 - write (imol2,'(a)') 'SMALL' - write (imol2,'(a)') 'USER_CHARGES' - write (imol2,'(a)') '\@ATOM' - do i=nnt,nct - write (zahl,'(i3)') i - pom=ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0 - enddo - write (imol2,'(a)') '\@BOND' - do i=nnt,nct-1 - write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 - enddo - do i=1,nss - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 - enddo - write (imol2,'(a)') '\@SUBSTRUCTURE' - do i=nnt,nct - write (zahl,'(i3)') i - pom = ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 - enddo - 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') - 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') - return - end subroutine MOL2out -!----------------------------------------------------------------------------- - subroutine intout - - use geometry_data - use energy_data, only: itype - ! use control -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.TORSION' -!el local variables - integer :: i,iti - - write (iout,'(/a)') 'Geometry of the virtual chain.' - write (iout,'(7a)') ' Res ',' d',' Theta',& - ' Phi',' Dsc',' Alpha',' Omega' - do i=1,nres - iti=itype(i) - write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),& - rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),& - rad2deg*omeg(i) - enddo - return - end subroutine intout -!----------------------------------------------------------------------------- -#ifdef CLUSTER - subroutine briefout(it,ener,free)!,plik) -#else - subroutine briefout(it,ener) -#endif - use geometry_data - use energy_data - ! use control -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.SBRIDGE' -! print '(a,i5)',intname,igeom -!el local variables - integer :: i,it - real(kind=8) :: ener,free -! character(len=80) :: plik -! integer :: iii - -#if defined(AIX) || defined(PGI) - open (igeom,file=intname,position='append') -#else - open (igeom,file=intname,access='append') -#endif -#ifdef WHAM_RUN -! iii=igeom - igeom=iout -#endif - IF (NSS.LE.9) THEN -#ifdef CLUSTER - WRITE (igeom,180) IT,ENER,free,NSS,(IHPB(I),JHPB(I),I=1,NSS) - ELSE - WRITE (igeom,180) IT,ENER,free,NSS,(IHPB(I),JHPB(I),I=1,8) -#else - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) - ELSE - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) -#endif - WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) - ENDIF -! IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) -! if (nvar.gt.nphi+ntheta) then - write (igeom,200) (rad2deg*alph(i),i=2,nres-1) - write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) -! endif - close(igeom) - 180 format (I5,F12.3,I2,9(1X,2I3)) - 190 format (3X,11(1X,2I3)) - 200 format (8F10.4) - return - end subroutine briefout -!----------------------------------------------------------------------------- -#ifdef WINIFL - subroutine fdate(fd) - character(len=32) :: fd - write(fd,'(32x)') - return - end subroutine fdate -#endif -!----------------------------------------------------------------------------- -#ifdef WHAM_RUN - real(kind=8) function gyrate(jcon) -#else - real(kind=8) function gyrate() -#endif - - use geometry_data, only: c - ! use geometry - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.INTERACT' -! include 'COMMON.CHAIN' - real(kind=8) :: rg - real(kind=8),dimension(3) :: cen -!el local variables - integer :: i,j,jcon - - do j=1,3 - cen(j)=0.0d0 - enddo - - do i=nnt,nct - do j=1,3 - cen(j)=cen(j)+c(j,i) - enddo - enddo - do j=1,3 - cen(j)=cen(j)/dble(nct-nnt+1) - enddo - rg = 0.0d0 - do i = nnt, nct - do j=1,3 - rg = rg + (c(j,i)-cen(j))**2 - enddo - end do -#ifdef WHAM_RUN - gyrate = dsqrt(rg/dble(nct-nnt+1)) -#else - gyrate = sqrt(rg/dble(nct-nnt+1)) -#endif - return - end function gyrate -#ifdef WHAM_RUN -!----------------------------------------------------------------------------- -! readrtns.F WHAM - subroutine reads(rekord,lancuch,wartosc,default) -! implicit none - character*(*) :: rekord,lancuch,wartosc,default - character(len=80) :: aux - integer :: lenlan,lenrec,iread,ireade -!el external ilen -!el logical iblnk -!el external iblnk - lenlan=ilen(lancuch) - lenrec=ilen(rekord) - iread=index(rekord,lancuch(:lenlan)//"=") -! print *,"rekord",rekord," lancuch",lancuch -! print *,"iread",iread," lenlan",lenlan," lenrec",lenrec - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+lenlan+1 -! print *,"iread",iread -! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) - do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) - iread=iread+1 -! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) - enddo -! print *,"iread",iread - if (iread.gt.lenrec) then - wartosc=default - return - endif - ireade=iread+1 -! print *,"ireade",ireade - do while (ireade.lt.lenrec .and. & - .not.iblnk(rekord(ireade:ireade))) - ireade=ireade+1 - enddo - wartosc=rekord(iread:ireade) - return - end subroutine reads -#endif -!----------------------------------------------------------------------------- -! permut.F -!----------------------------------------------------------------------------- - subroutine permut(isym) - - use geometry_data, only: tabperm -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.NAMES' -! include 'COMMON.CONTROL' - - integer :: n,isym -! logical nextp -!el external nextp - integer,dimension(isym) :: a -! parameter(n=symetr) -!el local variables - integer :: kkk,i - - n=isym - if (n.eq.1) then - tabperm(1,1)=1 - return - endif - kkk=0 - do i=1,n - a(i)=i - enddo - 10 print *,(a(i),i=1,n) - kkk=kkk+1 - do i=1,n - tabperm(kkk,i)=a(i) -! write (iout,*) "tututu", kkk - enddo - if(nextp(n,a)) go to 10 - return - end subroutine permut -!----------------------------------------------------------------------------- - logical function nextp(n,a) - - integer :: n,i,j,k,t -! logical :: nextp - integer,dimension(n) :: a - i=n-1 - 10 if(a(i).lt.a(i+1)) go to 20 - i=i-1 - if(i.eq.0) go to 20 - go to 10 - 20 j=i+1 - k=n - 30 t=a(j) - a(j)=a(k) - a(k)=t - j=j+1 - k=k-1 - if(j.lt.k) go to 30 - j=i - if(j.ne.0) go to 40 - nextp=.false. - return - 40 j=j+1 - if(a(j).lt.a(i)) go to 40 - t=a(i) - a(i)=a(j) - a(j)=t - nextp=.true. - return - end function nextp -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module io_base diff --git a/source/unres/io_config.F90 b/source/unres/io_config.F90 new file mode 100644 index 0000000..bae2a8c --- /dev/null +++ b/source/unres/io_config.F90 @@ -0,0 +1,4252 @@ + module io_config + + use names + use io_units + use io_base + use geometry_data + use geometry + use control_data, only:maxterm_sccor + implicit none +!----------------------------------------------------------------------------- +! Max. number of residue types and parameters in expressions for +! virtual-bond angle bending potentials +! integer,parameter :: maxthetyp=3 +! integer,parameter :: maxthetyp1=maxthetyp+1 +! ,maxtheterm=20, +! & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, +! & mmaxtheterm=maxtheterm) +!----------------------------------------------------------------------------- +! Max. number of types of dihedral angles & multiplicity of torsional barriers +! and the number of terms in double torsionals +! integer,parameter :: maxlor=3,maxtermd_1=8,maxtermd_2=8 +! parameter (maxtor=4,maxterm=10) +!----------------------------------------------------------------------------- +! Max number of torsional terms in SCCOR +!el integer,parameter :: maxterm_sccor=6 +!----------------------------------------------------------------------------- + character(len=1),dimension(:),allocatable :: secstruc !(maxres) +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- +! bank.F io_csa +!----------------------------------------------------------------------------- + subroutine write_rbank(jlee,adif,nft) + + use csa_data + use geometry_data, only: nres,rad2deg +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +!el local variables + integer :: nft,i,k,j,l,jlee + real(kind=8) :: adif + + open(icsa_rbank,file=csa_rbank,status="unknown") + write (icsa_rbank,900) jlee,nbank,nstep,nft,icycle,adif + do k=1,nbank + write (icsa_rbank,952) k,rene(k),rrmsn(k),rpncn(k) + do j=1,numch + do l=2,nres-1 + write (icsa_rbank,850) (rad2deg*rvar(i,l,j,k),i=1,4) + enddo + enddo + enddo + close(icsa_rbank) + + 850 format (10f8.3) + 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =",& + i8,i10,i2,f15.5) + 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& + ' %NC ',0pf5.2) + + return + end subroutine write_rbank +!----------------------------------------------------------------------------- + subroutine read_rbank(jlee,adif) + + use csa_data + use geometry_data, only: nres,deg2rad + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.SETUP' + character(len=80) :: karta +!el local variables + integer :: nbankr,nstepr,nftr,icycler,kk,k,j,l,i,& + ierror,ierrcode,jlee,jleer + real(kind=8) :: adif + + open(icsa_rbank,file=csa_rbank,status="old") + read (icsa_rbank,901) jleer,nbankr,nstepr,nftr,icycler,adif + print *,jleer,nbankr,nstepr,nftr,icycler,adif +! print *, 'adif from read_rbank ',adif +#ifdef MPI + if(nbankr.ne.nbank) then + write (iout,*) 'ERROR in READ_BANK: NBANKR',nbankr,& + ' NBANK',nbank + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + if(jleer.ne.jlee) then + write (iout,*) 'ERROR in READ_BANK: JLEER',jleer,& + ' JLEE',jlee + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif +#endif + + kk=0 + do k=1,nbankr + read (icsa_rbank,'(a80)') karta + write(iout,*) "READ_RBANK: kk=",kk + write(iout,*) karta +! if (index(karta,"*").gt.0) then +! write (iout,*) "***** Stars in bankr ***** k=",k, +! & " skipped" +! do j=1,numch +! do l=2,nres-1 +! read (30,850) (rdummy,i=1,4) +! enddo +! enddo +! else + kk=kk+1 + call reada(karta,"total E",rene(kk),1.0d20) + call reada(karta,"rmsd from N",rrmsn(kk),0.0d0) + call reada(karta,"%NC",rpncn(kk),0.0d0) + write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk),& + "%NC",bpncn(kk),ibank(kk) +! read (icsa_rbank,953) kdummy,rene(kk),rrmsn(kk),rpncn(kk) + do j=1,numch + do l=2,nres-1 + read (icsa_rbank,850) (rvar(i,l,j,kk),i=1,4) +! write (iout,850) (rvar(i,l,j,kk),i=1,4) + do i=1,4 + rvar(i,l,j,kk)=deg2rad*rvar(i,l,j,kk) + enddo + enddo + enddo +! endif + enddo +!d write (*,*) "read_rbank ******************* kk",kk, +!d & "nbankr",nbankr + if (kk.lt.nbankr) nbankr=kk +!d do kk=1,nbankr +!d print *,"kk=",kk +!d do j=1,numch +!d do l=2,nres-1 +!d write (*,850) (rvar(i,l,j,kk),i=1,4) +!d enddo +!d enddo +!d enddo + close(icsa_rbank) + + 850 format (10f8.3) + 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) + 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2) + + return + end subroutine read_rbank +!----------------------------------------------------------------------------- + subroutine write_bank(jlee,nft) + + use csa_data + use control_data, only: vdisulf + use geometry_data, only: nres,rad2deg +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' + character(len=7) :: chtmp + character(len=40) :: chfrm +!el external ilen +!el local variables + integer :: nft,k,l,i,j,jlee + + open(icsa_bank,file=csa_bank,status="unknown") + write (icsa_bank,900) jlee,nbank,nstep,nft,icycle,cutdif + write (icsa_bank,902) nglob_csa, eglob_csa + open (igeom,file=intname,status='UNKNOWN') + do k=1,nbank + write (icsa_bank,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) + if (vdisulf) write (icsa_bank,'(101i4)') & + bvar_nss(k),((bvar_ss(j,i,k),j=1,2),i=1,bvar_nss(k)) + do j=1,numch + do l=2,nres-1 + write (icsa_bank,850) (rad2deg*bvar(i,l,j,k),i=1,4) + enddo + enddo + if (bvar_nss(k).le.9) then + write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& + bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) + else + write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& + bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) + write (igeom,'(3X,11(1X,2I3))') (bvar_ss(1,i,k),& + bvar_ss(2,i,k),i=10,bvar_nss(k)) + endif + write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) + write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) + write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) + write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) + enddo + close(icsa_bank) + close(igeom) + + if (nstep/200.gt.ilastnstep) then + + ilastnstep=(ilastnstep+1)*1.5 + write(chfrm,'(a2,i1,a1)') '(i',int(dlog10(dble(nstep))+1),')' + write(chtmp,chfrm) nstep + open(icsa_int,file=prefix(:ilen(prefix)) & + //'_'//chtmp(:ilen(chtmp))//'.int',status='UNKNOWN') + do k=1,nbank + if (bvar_nss(k).le.9) then + write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& + bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) + else + write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& + bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) + write (icsa_int,'(3X,11(1X,2I3))') (bvar_ss(1,i,k),& + bvar_ss(2,i,k),i=10,bvar_nss(k)) + endif + write (icsa_int,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) + write (icsa_int,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) + write (icsa_int,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) + write (icsa_int,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) + enddo + close(icsa_int) + endif + + + 200 format (8f10.4) + 850 format (10f8.3) + 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =",& + i8,i10,i2,f15.5) + 902 format (1x,'nglob_csa =',i4,' eglob_csa =',1pe14.5) + 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& + ' %NC ',0pf5.2,i5) + + return + end subroutine write_bank +!----------------------------------------------------------------------------- + subroutine write_bank_reminimized(jlee,nft) + + use csa_data + use geometry_data, only: nres,rad2deg + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.SBRIDGE' +!el local variables + integer :: nft,i,l,j,k,jlee + + open(icsa_bank_reminimized,file=csa_bank_reminimized,& + status="unknown") + write (icsa_bank_reminimized,900) & + jlee,nbank,nstep,nft,icycle,cutdif + open (igeom,file=intname,status='UNKNOWN') + do k=1,nbank + write (icsa_bank_reminimized,952) k,bene(k),brmsn(k),& + bpncn(k),ibank(k) + do j=1,numch + do l=2,nres-1 + write (icsa_bank_reminimized,850) (rad2deg*bvar(i,l,j,k),i=1,4) + enddo + enddo + if (nss.le.9) then + write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& + nss,(ihpb(i),jhpb(i),i=1,nss) + else + write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& + nss,(ihpb(i),jhpb(i),i=1,9) + write (igeom,'(3X,11(1X,2I3))') (ihpb(i),jhpb(i),i=10,nss) + endif + write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) + write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) + write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) + write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) + enddo + close(icsa_bank_reminimized) + close(igeom) + + 200 format (8f10.4) + 850 format (10f8.3) + 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =",& + i8,i10,i2,f15.5) + 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& + ' %NC ',0pf5.2,i5) + + return + end subroutine write_bank_reminimized +!----------------------------------------------------------------------------- + subroutine read_bank(jlee,nft,cutdifr) + + use csa_data + use control_data, only: vdisulf + use geometry_data, only: nres,deg2rad + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.CONTROL' +! include 'COMMON.SBRIDGE' + character(len=80) :: karta +! integer ilen +!el external ilen +!el local variables + integer :: nft,kk,k,l,i,j,jlee + real(kind=8) :: cutdifr + + open(icsa_bank,file=csa_bank,status="old") + read (icsa_bank,901) jlee,nbank,nstep,nft,icycle,cutdifr + read (icsa_bank,902) nglob_csa, eglob_csa +! if(jleer.ne.jlee) then +! write (iout,*) 'ERROR in READ_BANK: JLEER',jleer, +! & ' JLEE',jlee +! call mpi_abort(mpi_comm_world,ierror,ierrcode) +! endif + + kk=0 + do k=1,nbank + read (icsa_bank,'(a80)') karta + write(iout,*) "READ_BANK: kk=",kk + write(iout,*) karta +! if (index(karta,"*").gt.0) then +! write (iout,*) "***** Stars in bank ***** k=",k, +! & " skipped" +! do j=1,numch +! do l=2,nres-1 +! read (33,850) (rdummy,i=1,4) +! enddo +! enddo +! else + kk=kk+1 + call reada(karta,"total E",bene(kk),1.0d20) + call reada(karta,"rmsd from N",brmsn(kk),0.0d0) + call reada(karta,"%NC",bpncn(kk),0.0d0) + read (karta(ilen(karta)-1:),*,end=111,err=111) ibank(kk) + goto 112 + 111 ibank(kk)=0 + 112 continue + write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk),& + "%NC",bpncn(kk),ibank(kk) +! read (icsa_bank,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) + if (vdisulf) then + read (icsa_bank,'(101i4)') & + bvar_nss(kk),((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) + bvar_ns(kk)=ns-2*bvar_nss(kk) + write(iout,*) 'read SSBOND',bvar_nss(kk),& + ((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) +!d write(iout,*) 'read CYS #free ', bvar_ns(kk) + l=0 + do i=1,ns + j=1 + do while( iss(i).ne.bvar_ss(1,j,kk)-nres .and. & + iss(i).ne.bvar_ss(2,j,kk)-nres .and. & + j.le.bvar_nss(kk)) + j=j+1 + enddo + if (j.gt.bvar_nss(kk)) then + l=l+1 + bvar_s(l,kk)=iss(i) + endif + enddo +!d write(iout,*)'read CYS free',(bvar_s(l,kk),l=1,bvar_ns(kk)) + endif + do j=1,numch + do l=2,nres-1 + read (icsa_bank,850) (bvar(i,l,j,kk),i=1,4) +! write (iout,850) (bvar(i,l,j,kk),i=1,4) + do i=1,4 + bvar(i,l,j,kk)=deg2rad*bvar(i,l,j,kk) + enddo ! l + enddo ! l + enddo ! j +! endif + enddo ! k + + if (kk.lt.nbank) nbank=kk +!d write (*,*) "read_bank ******************* kk",kk, +!d & "nbank",nbank +!d do kk=1,nbank +!d print *,"kk=",kk +!d do j=1,numch +!d do l=2,nres-1 +!d write (*,850) (bvar(i,l,j,kk),i=1,4) +!d enddo +!d enddo +!d enddo + +! do k=1,nbank +! read (33,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) +! do j=1,numch +! do l=2,nres-1 +! read (33,850) (bvar(i,l,j,k),i=1,4) +! do i=1,4 +! bvar(i,l,j,k)=deg2rad*bvar(i,l,j,k) +! enddo +! enddo +! enddo +! enddo + close(icsa_bank) + + 850 format (10f8.3) + 952 format (1x,'#',i4,' total E ',f12.3,' rmsd from N ',f8.3,i5) + 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) + 902 format (1x,11x,i4,12x,1pe14.5) + 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2,i5) + + return + end subroutine read_bank +!----------------------------------------------------------------------------- + subroutine write_bank1(jlee) + + use csa_data + use geometry_data, only: nres,rad2deg +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +!el local variables + integer :: k,i,l,j,jlee + +#if defined(AIX) || defined(PGI) + open(icsa_bank1,file=csa_bank1,position="append") +#else + open(icsa_bank1,file=csa_bank1,access="append") +#endif + write (icsa_bank1,900) jlee,nbank,nstep,cutdif + do k=1,nbank + write (icsa_bank1,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) + do j=1,numch + do l=2,nres-1 + write (icsa_bank1,850) (rad2deg*bvar(i,l,j,k),i=1,4) + enddo + enddo + enddo + close(icsa_bank1) + 850 format (10f8.3) + 900 format (4x,"jlee =",i5,3x,"nbank =",i5,3x,"nstep =",i10,f15.5) + 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& + ' %NC ',0pf5.2,i5) + + return + end subroutine write_bank1 +!----------------------------------------------------------------------------- +! cartprint.f +!----------------------------------------------------------------------------- +! subroutine cartprint + +! use geometry_data, only: c +! use energy_data, only: itype +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! integer :: i + +! write (iout,100) +! do i=1,nres +! write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),& +! c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) +! enddo +! 100 format (//' alpha-carbon coordinates ',& +! ' centroid coordinates'/ & +! ' ', 6X,'X',11X,'Y',11X,'Z',& +! 10X,'X',11X,'Y',11X,'Z') +! 110 format (a,'(',i3,')',6f12.5) +! return +! end subroutine cartprint +!----------------------------------------------------------------------------- +! dihed_cons.F +!----------------------------------------------------------------------------- + subroutine secstrp2dihc + + use geometry_data + use energy_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.BOUNDS' +! include 'COMMON.CHAIN' +! include 'COMMON.TORCNSTR' +! include 'COMMON.IOUNITS' +!el character(len=1),dimension(nres) :: secstruc !(maxres) +!el COMMON/SECONDARYS/secstruc + character(len=80) :: line + logical :: errflag +!el external ilen + +!el local variables + integer :: i,ii,lenpre + + allocate(secstruc(nres)) + +!dr call getenv_loc('SECPREDFIL',secpred) + lenpre=ilen(prefix) + secpred=prefix(:lenpre)//'.spred' + +#if defined(WINIFL) || defined(WINPGI) + open(isecpred,file=secpred,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open(isecpred,file=secpred,status='old',action='read') +#elif (defined G77) + open(isecpred,file=secpred,status='old') +#else + open(isecpred,file=secpred,status='old',action='read') +#endif +! read secondary structure prediction from JPRED here! +! read(isecpred,'(A80)',err=100,end=100) line +! read(line,'(f10.3)',err=110) ftors + read(isecpred,'(f10.3)',err=110) ftors + + write (iout,*) 'FTORS factor =',ftors +! initialize secstruc to any + do i=1,nres + secstruc(i) ='-' + enddo + ndih_constr=0 + ndih_nconstr=0 + + call read_secstr_pred(isecpred,iout,errflag) + if (errflag) then + write(iout,*)'There is a problem with the list of secondary-',& + 'structure prediction' + goto 100 + endif +! 8/13/98 Set limits to generating the dihedral angles + do i=1,nres + phibound(1,i)=-pi + phibound(2,i)=pi + enddo + + ii=0 + do i=1,nres + if ( secstruc(i) .eq. 'H') then +! Helix restraints for this residue + ii=ii+1 + idih_constr(ii)=i + phi0(ii) = 45.0D0*deg2rad + drange(ii)= 5.0D0*deg2rad + phibound(1,i) = phi0(ii)-drange(ii) + phibound(2,i) = phi0(ii)+drange(ii) + else if (secstruc(i) .eq. 'E') then +! strand restraints for this residue + ii=ii+1 + idih_constr(ii)=i + phi0(ii) = 180.0D0*deg2rad + drange(ii)= 5.0D0*deg2rad + phibound(1,i) = phi0(ii)-drange(ii) + phibound(2,i) = phi0(ii)+drange(ii) + else +! no restraints for this residue + ndih_nconstr=ndih_nconstr+1 + idih_nconstr(ndih_nconstr)=i + endif + enddo + ndih_constr=ii +! deallocate(secstruc) + return +100 continue + write(iout,'(A30,A80)')'Error reading file SECPRED',secpred +! deallocate(secstruc) + return +110 continue + write(iout,'(A20)')'Error reading FTORS' +! deallocate(secstruc) + return + end subroutine secstrp2dihc +!----------------------------------------------------------------------------- + subroutine read_secstr_pred(jin,jout,errors) + +! implicit real*8 (a-h,o-z) +! INCLUDE 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +!el character(len=1),dimension(nres) :: secstruc !(maxres) +!el COMMON/SECONDARYS/secstruc +!el EXTERNAL ILEN + character(len=80) :: line,line1 !,ucase + logical :: errflag,errors,blankline + +!el local variables + integer :: jin,jout,iseq,ipos,ipos1,iend,il,& + length_of_chain + errors=.false. + read (jin,'(a)') line + write (jout,'(2a)') '> ',line(1:78) + line1=ucase(line) +! Remember that we number full residues starting from 2, then, iseq=1 and iseq=nres +! correspond to the end-groups. ADD to the secondary structure prediction "-" for the +! end-groups in the input file "*.spred" + + iseq=1 + do while (index(line1,'$END').eq.0) +! Override commented lines. + ipos=1 + blankline=.false. + do while (.not.blankline) + line1=' ' + call mykey(line,line1,ipos,blankline,errflag) + if (errflag) write (jout,'(2a)') & + 'Error when reading sequence in line: ',line + errors=errors .or. errflag + if (.not. blankline .and. .not. errflag) then + ipos1=2 + iend=ilen(line1) +!el if (iseq.le.maxres) then + if (line1(1:1).eq.'-' ) then + secstruc(iseq)=line1(1:1) + else if ( ( ucase(line1(1:1)).eq.'E' ) .or. & + ( ucase(line1(1:1)).eq.'H' ) ) then + secstruc(iseq)=ucase(line1(1:1)) + else + errors=.true. + write (jout,1010) line1(1:1), iseq + goto 80 + endif +!el else +!el errors=.true. +!el write (jout,1000) iseq,maxres +!el goto 80 +!el endif + do while (ipos1.le.iend) + + iseq=iseq+1 + il=1 + ipos1=ipos1+1 +!el if (iseq.le.maxres) then + if (line1(ipos1-1:ipos1-1).eq.'-' ) then + secstruc(iseq)=line1(ipos1-1:ipos1-1) + else if((ucase(line1(ipos1-1:ipos1-1)).eq.'E').or. & + (ucase(line1(ipos1-1:ipos1-1)).eq.'H') ) then + secstruc(iseq)=ucase(line1(ipos1-1:ipos1-1)) + else + errors=.true. + write (jout,1010) line1(ipos1-1:ipos1-1), iseq + goto 80 + endif +!el else +!el errors=.true. +!el write (jout,1000) iseq,maxres +!el goto 80 +!el endif + enddo + iseq=iseq+1 + endif + enddo + read (jin,'(a)') line + write (jout,'(2a)') '> ',line(1:78) + line1=ucase(line) + enddo + +!d write (jout,'(10a8)') (sequence(i),i=1,iseq-1) + +!d check whether the found length of the chain is correct. + length_of_chain=iseq-1 + if (length_of_chain .ne. nres) then +! errors=.true. + write (jout,'(a,i4,a,i4,a)') & + 'Error: the number of labels specified in $SEC_STRUC_PRED (' & + ,length_of_chain,') does not match with the number of residues (' & + ,nres,').' + endif + 80 continue + + 1000 format('Error - the number of residues (',i4,& + ') has exceeded maximum (',i4,').') + 1010 format ('Error - unrecognized secondary structure label',a4,& + ' in position',i4) + return + end subroutine read_secstr_pred +!#endif +!----------------------------------------------------------------------------- +! parmread.F +!----------------------------------------------------------------------------- + subroutine parmread + + use geometry_data + use energy_data + use control_data, only:maxtor,maxterm + use MD_data + use MPI_data +!el use map_data + use control, only: getenv_loc +! +! Read the parameters of the probability distributions of the virtual-bond +! valence angles and the side chains and energy parameters. +! +! Important! Energy-term weights ARE NOT read here; they are read from the +! main input file instead, because NO defaults have yet been set for these +! parameters. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + integer :: IERROR +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.SCCOR' +! include 'COMMON.SCROT' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' +! include 'COMMON.SBRIDGE' +! include 'COMMON.MD' +! include 'COMMON.SETUP' + character(len=1) :: t1,t2,t3 + character(len=1) :: onelett(4) = (/"G","A","P","D"/) + character(len=1) :: toronelet(-2:2) = (/"p","a","G","A","P"/) + logical :: lprint,LaTeX + real(kind=8),dimension(3,3,maxlob) :: blower !(3,3,maxlob) + real(kind=8),dimension(13) :: bN + character(len=3) :: lancuch !,ucase +!el local variables + integer :: m,n,l,i,j,k,iblock,lll,llll,ll,nlobi,mm + integer :: maxinter,junk,kk,ii + real(kind=8) :: v0ijsccor,v0ijsccor1,v0ijsccor2,v0ijsccor3,si,& + dwa16,rjunk,akl,v0ij,rri,epsij,rrij,sigeps,sigt1sq,& + sigt2sq,sigii1,sigii2,ratsig1,ratsig2,rsum_max,r_augm,& + res1 + integer :: ichir1,ichir2 +! real(kind=8),dimension(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) :: v1_el,v2_el !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) +!el allocate(v1_el(maxterm,-maxtor:maxtor,-maxtor:maxtor,2)) +!el allocate(v2_el(maxterm,-maxtor:maxtor,-maxtor:maxtor,2)) +! +! For printing parameters after they are read set the following in the UNRES +! C-shell script: +! +! setenv PRINT_PARM YES +! +! To print parameters in LaTeX format rather than as ASCII tables: +! +! setenv LATEX YES +! + call getenv_loc("PRINT_PARM",lancuch) + lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") + call getenv_loc("LATEX",lancuch) + LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") +! + dwa16=2.0d0**(1.0d0/6.0d0) + itypro=20 +! Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv +! +! Read the virtual-bond parameters, masses, and moments of inertia +! and Stokes' radii of the peptide group and side chains +! + allocate(dsc(ntyp1)) !(ntyp1) + allocate(dsc_inv(ntyp1)) !(ntyp1) + allocate(nbondterm(ntyp)) !(ntyp) + allocate(vbldsc0(maxbondterm,ntyp)) !(maxbondterm,ntyp) + allocate(aksc(maxbondterm,ntyp)) !(maxbondterm,ntyp) + allocate(msc(ntyp+1)) !(ntyp+1) + allocate(isc(ntyp+1)) !(ntyp+1) + allocate(restok(ntyp+1)) !(ntyp+1) + allocate(abond0(maxbondterm,ntyp)) !(maxbondterm,ntyp) + + dsc(:)=0.0d0 + dsc_inv(:)=0.0d0 + +#ifdef CRYST_BOND + read (ibond,*) vbldp0,akp,mp,ip,pstok + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*) vbldsc0(1,i),aksc(1,i),msc(i),isc(i),restok(i) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#else + read (ibond,*) junk,vbldp0,akp,rjunk,mp,ip,pstok + do i=1,ntyp + read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i),& + j=1,nbondterm(i)),msc(i),isc(i),restok(i) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#endif + if (lprint) then + write(iout,'(/a/)')"Dynamic constants of the interaction sites:" + write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass',& + 'inertia','Pstok' + write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok + do i=1,ntyp + write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i),& + vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i) + do j=2,nbondterm(i) + write (iout,'(13x,3f10.5)') & + vbldsc0(j,i),aksc(j,i),abond0(j,i) + enddo + enddo + endif +!---------------------------------------------------- + allocate(a0thet(-ntyp:ntyp),theta0(-ntyp:ntyp)) + allocate(sig0(-ntyp:ntyp),sigc0(-ntyp:ntyp)) !(-ntyp:ntyp) + allocate(athet(2,-ntyp:ntyp,-1:1,-1:1)) + allocate(bthet(2,-ntyp:ntyp,-1:1,-1:1)) !(2,-ntyp:ntyp,-1:1,-1:1) + allocate(polthet(0:3,-ntyp:ntyp)) !(0:3,-ntyp:ntyp) + allocate(gthet(3,-ntyp:ntyp)) !(3,-ntyp:ntyp) + + a0thet(:)=0.0D0 + athet(:,:,:,:)=0.0D0 + bthet(:,:,:,:)=0.0D0 + polthet(:,:)=0.0D0 + gthet(:,:)=0.0D0 + theta0(:)=0.0D0 + sig0(:)=0.0D0 + sigc0(:)=0.0D0 + +#ifdef CRYST_THETA +! +! Read the parameters of the probability distribution/energy expression +! of the virtual-bond valence angles theta +! + do i=1,ntyp + read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i,1,1),j=1,2),& + (bthet(j,i,1,1),j=1,2) + read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3) + read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3) + read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + do i=1,ntyp + athet(1,i,1,-1)=athet(1,i,1,1) + athet(2,i,1,-1)=athet(2,i,1,1) + bthet(1,i,1,-1)=-bthet(1,i,1,1) + bthet(2,i,1,-1)=-bthet(2,i,1,1) + athet(1,i,-1,1)=-athet(1,i,1,1) + athet(2,i,-1,1)=-athet(2,i,1,1) + bthet(1,i,-1,1)=bthet(1,i,1,1) + bthet(2,i,-1,1)=bthet(2,i,1,1) + enddo + do i=-ntyp,-1 + a0thet(i)=a0thet(-i) + athet(1,i,-1,-1)=athet(1,-i,1,1) + athet(2,i,-1,-1)=-athet(2,-i,1,1) + bthet(1,i,-1,-1)=bthet(1,-i,1,1) + bthet(2,i,-1,-1)=-bthet(2,-i,1,1) + athet(1,i,-1,1)=athet(1,-i,1,1) + athet(2,i,-1,1)=-athet(2,-i,1,1) + bthet(1,i,-1,1)=-bthet(1,-i,1,1) + bthet(2,i,-1,1)=bthet(2,-i,1,1) + athet(1,i,1,-1)=-athet(1,-i,1,1) + athet(2,i,1,-1)=athet(2,-i,1,1) + bthet(1,i,1,-1)=bthet(1,-i,1,1) + bthet(2,i,1,-1)=-bthet(2,-i,1,1) + theta0(i)=theta0(-i) + sig0(i)=sig0(-i) + sigc0(i)=sigc0(-i) + do j=0,3 + polthet(j,i)=polthet(j,-i) + enddo + do j=1,3 + gthet(j,i)=gthet(j,-i) + enddo + enddo + + close (ithep) + if (lprint) then + if (.not.LaTeX) then + write (iout,'(a)') & + 'Parameters of the virtual-bond valence angles:' + write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:',& + ' ATHETA0 ',' A1 ',' A2 ',& + ' B1 ',' B2 ' + do i=1,ntyp + write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,& + a0thet(i),(athet(j,i,1,1),j=1,2),(bthet(j,i,1,1),j=1,2) + enddo + write (iout,'(/a/9x,5a/79(1h-))') & + 'Parameters of the expression for sigma(theta_c):',& + ' ALPH0 ',' ALPH1 ',' ALPH2 ',& + ' ALPH3 ',' SIGMA0C ' + do i=1,ntyp + write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,& + (polthet(j,i),j=0,3),sigc0(i) + enddo + write (iout,'(/a/9x,5a/79(1h-))') & + 'Parameters of the second gaussian:',& + ' THETA0 ',' SIGMA0 ',' G1 ',& + ' G2 ',' G3 ' + do i=1,ntyp + write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i),& + sig0(i),(gthet(j,i),j=1,3) + enddo + else + write (iout,'(a)') & + 'Parameters of the virtual-bond valence angles:' + write (iout,'(/a/9x,5a/79(1h-))') & + 'Coefficients of expansion',& + ' theta0 ',' a1*10^2 ',' a2*10^2 ',& + ' b1*10^1 ',' b2*10^1 ' + do i=1,ntyp + write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),& + a0thet(i),(100*athet(j,i,1,1),j=1,2),& + (10*bthet(j,i,1,1),j=1,2) + enddo + write (iout,'(/a/9x,5a/79(1h-))') & + 'Parameters of the expression for sigma(theta_c):',& + ' alpha0 ',' alph1 ',' alph2 ',& + ' alhp3 ',' sigma0c ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i),& + (polthet(j,i),j=0,3),sigc0(i) + enddo + write (iout,'(/a/9x,5a/79(1h-))') & + 'Parameters of the second gaussian:',& + ' theta0 ',' sigma0*10^2 ',' G1*10^-1',& + ' G2 ',' G3*10^1 ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i),& + 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 + enddo + endif + endif +#else +! +! Read the parameters of Utheta determined from ab initio surfaces +! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +! + read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2,& + ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + +!---------------------------------------------------- + allocate(ithetyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) + allocate(aa0thet(-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + allocate(aathet(ntheterm,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(maxtheterm,-maxthetyp1:maxthetyp1,& +! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + allocate(bbthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(ccthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(ddthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(eethet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& +! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + allocate(ffthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(ggthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,& +! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + + read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1) + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo + + aa0thet(:,:,:,:)=0.0d0 + aathet(:,:,:,:,:)=0.0d0 + bbthet(:,:,:,:,:,:)=0.0d0 + ccthet(:,:,:,:,:,:)=0.0d0 + ddthet(:,:,:,:,:,:)=0.0d0 + eethet(:,:,:,:,:,:)=0.0d0 + ffthet(:,:,:,:,:,:,:)=0.0d0 + ggthet(:,:,:,:,:,:,:)=0.0d0 + +! VAR:iblock means terminally blocking group 1=non-proline 2=proline + do iblock=1,2 +! VAR:ntethtyp is type of theta potentials type currently 0=glycine +! VAR:1=non-glicyne non-proline 2=proline +! VAR:negative values for D-aminoacid + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)',end=111,err=111) res1 + read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock) +! VAR: aa0thet is variable describing the average value of Foureir +! VAR: expansion series +! VAR: aathet is foureir expansion in theta/2 angle for full formula +! VAR: look at the fitting equation in Kozlowska et al., J. Phys.: +!ondens. Matter 19 (2007) 285203 and Sieradzan et al., unpublished + read (ithep,*,end=111,err=111) & + (aathet(l,i,j,k,iblock),l=1,ntheterm) + read (ithep,*,end=111,err=111) & + ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + ll=1,ntheterm2) + read (ithep,*,end=111,err=111) & + (((ffthet(llll,lll,ll,i,j,k,iblock),& + ffthet(lll,llll,ll,i,j,k,iblock),& + ggthet(llll,lll,ll,i,j,k,iblock),& + ggthet(lll,llll,ll,i,j,k,iblock),& + llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) + enddo + enddo + enddo +! +! For dummy ends assign glycine-type coefficients of theta-only terms; the +! coefficients of theta-and-gamma-dependent terms are zero. +! IF YOU WANT VALENCE POTENTIALS FOR DUMMY ATOM UNCOMENT BELOW (NOT +! RECOMENTDED AFTER VERSION 3.3) +! do i=1,nthetyp +! do j=1,nthetyp +! do l=1,ntheterm +! aathet(l,i,j,nthetyp+1,iblock)=aathet(l,i,j,1,iblock) +! aathet(l,nthetyp+1,i,j,iblock)=aathet(l,1,i,j,iblock) +! enddo +! aa0thet(i,j,nthetyp+1,iblock)=aa0thet(i,j,1,iblock) +! aa0thet(nthetyp+1,i,j,iblock)=aa0thet(1,i,j,iblock) +! enddo +! do l=1,ntheterm +! aathet(l,nthetyp+1,i,nthetyp+1,iblock)=aathet(l,1,i,1,iblock) +! enddo +! aa0thet(nthetyp+1,i,nthetyp+1,iblock)=aa0thet(1,i,1,iblock) +! enddo +! enddo +! AND COMMENT THE LOOPS BELOW + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1,iblock)=0.0d0 + aathet(l,nthetyp+1,i,j,iblock)=0.0d0 + enddo + aa0thet(i,j,nthetyp+1,iblock)=0.0d0 + aa0thet(nthetyp+1,i,j,iblock)=0.0d0 + enddo + do l=1,ntheterm + aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 + enddo + aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 + enddo + enddo !iblock + +! TILL HERE +! Substitution for D aminoacids from symmetry. + do iblock=1,2 + do i=-nthetyp,0 + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock) + do l=1,ntheterm + aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock) + enddo + do ll=1,ntheterm2 + do lll=1,nsingle + bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock) + ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock) + ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock) + eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock) + enddo + enddo + do ll=1,ntheterm3 + do lll=2,ndouble + do llll=1,lll-1 + ffthet(llll,lll,ll,i,j,k,iblock)= & + ffthet(llll,lll,ll,-i,-j,-k,iblock) + ffthet(lll,llll,ll,i,j,k,iblock)= & + ffthet(lll,llll,ll,-i,-j,-k,iblock) + ggthet(llll,lll,ll,i,j,k,iblock)= & + -ggthet(llll,lll,ll,-i,-j,-k,iblock) + ggthet(lll,llll,ll,i,j,k,iblock)= & + -ggthet(lll,llll,ll,-i,-j,-k,iblock) + enddo !ll + enddo !lll + enddo !llll + enddo !k + enddo !j + enddo !i + enddo !iblock +! +! Control printout of the coefficients of virtual-bond-angle potentials +! + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do iblock=1,2 + do i=1,nthetyp+1 + do j=1,nthetyp+1 + do k=1,nthetyp+1 + write (iout,'(//4a)') & + 'Type ',onelett(i),onelett(j),onelett(k) + write (iout,'(//a,10x,a)') " l","a[l]" + write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) + write (iout,'(i2,1pe15.5)') & + (l,aathet(l,i,j,k,iblock),l=1,ntheterm) + do l=1,ntheterm2 + write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))') & + "b",l,"c",l,"d",l,"e",l + do m=1,nsingle + write (iout,'(i2,4(1pe15.5))') m,& + bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock),& + ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) + enddo + enddo + do l=1,ntheterm3 + write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))') & + "f+",l,"f-",l,"g+",l,"g-",l + do m=2,ndouble + do n=1,m-1 + write (iout,'(i1,1x,i1,4(1pe15.5))') n,m,& + ffthet(n,m,l,i,j,k,iblock),& + ffthet(m,n,l,i,j,k,iblock),& + ggthet(n,m,l,i,j,k,iblock),& + ggthet(m,n,l,i,j,k,iblock) + enddo !n + enddo !m + enddo !l + enddo !k + enddo !j + enddo !i + enddo + call flush(iout) + endif + write (2,*) "Start reading THETA_PDB",ithep_pdb + do i=1,ntyp +! write (2,*) 'i=',i + read (ithep_pdb,*,err=111,end=111) & + a0thet(i),(athet(j,i,1,1),j=1,2),& + (bthet(j,i,1,1),j=1,2) + read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) + read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) + read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + do i=1,ntyp + athet(1,i,1,-1)=athet(1,i,1,1) + athet(2,i,1,-1)=athet(2,i,1,1) + bthet(1,i,1,-1)=-bthet(1,i,1,1) + bthet(2,i,1,-1)=-bthet(2,i,1,1) + athet(1,i,-1,1)=-athet(1,i,1,1) + athet(2,i,-1,1)=-athet(2,i,1,1) + bthet(1,i,-1,1)=bthet(1,i,1,1) + bthet(2,i,-1,1)=bthet(2,i,1,1) + enddo + do i=-ntyp,-1 + a0thet(i)=a0thet(-i) + athet(1,i,-1,-1)=athet(1,-i,1,1) + athet(2,i,-1,-1)=-athet(2,-i,1,1) + bthet(1,i,-1,-1)=bthet(1,-i,1,1) + bthet(2,i,-1,-1)=-bthet(2,-i,1,1) + athet(1,i,-1,1)=athet(1,-i,1,1) + athet(2,i,-1,1)=-athet(2,-i,1,1) + bthet(1,i,-1,1)=-bthet(1,-i,1,1) + bthet(2,i,-1,1)=bthet(2,-i,1,1) + athet(1,i,1,-1)=-athet(1,-i,1,1) + athet(2,i,1,-1)=athet(2,-i,1,1) + bthet(1,i,1,-1)=bthet(1,-i,1,1) + bthet(2,i,1,-1)=-bthet(2,-i,1,1) + theta0(i)=theta0(-i) + sig0(i)=sig0(-i) + sigc0(i)=sigc0(-i) + do j=0,3 + polthet(j,i)=polthet(j,-i) + enddo + do j=1,3 + gthet(j,i)=gthet(j,-i) + enddo + enddo + write (2,*) "End reading THETA_PDB" + close (ithep_pdb) +#endif + close(ithep) + +!------------------------------------------- + allocate(nlob(ntyp1)) !(ntyp1) + allocate(bsc(maxlob,ntyp)) !(maxlob,ntyp) + allocate(censc(3,maxlob,-ntyp:ntyp)) !(3,maxlob,-ntyp:ntyp) + allocate(gaussc(3,3,maxlob,-ntyp:ntyp)) !(3,3,maxlob,-ntyp:ntyp) + + bsc(:,:)=0.0D0 + nlob(:)=0 + nlob(:)=0 + dsc(:)=0.0D0 + censc(:,:,:)=0.0D0 + gaussc(:,:,:,:)=0.0D0 + +#ifdef CRYST_SC +! +! Read the parameters of the probability distribution/energy expression +! of the side chains. +! + do i=1,ntyp + read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3),& + ((blower(k,l,1),l=1,k),k=1,3) + censc(1,1,-i)=censc(1,1,i) + censc(2,1,-i)=censc(2,1,i) + censc(3,1,-i)=-censc(3,1,i) + do j=2,nlob(i) + read (irotam,*,end=112,err=112) bsc(j,i) + read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3),& + ((blower(k,l,j),l=1,k),k=1,3) + censc(1,j,-i)=censc(1,j,i) + censc(2,j,-i)=censc(2,j,i) + censc(3,j,-i)=-censc(3,j,i) +! BSC is amplitude of Gaussian + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + if (((k.eq.3).and.(l.ne.3)) & + .or.((l.eq.3).and.(k.ne.3))) then + gaussc(k,l,j,-i)=-akl + gaussc(l,k,j,-i)=-akl + else + gaussc(k,l,j,-i)=akl + gaussc(l,k,j,-i)=akl + endif + enddo + enddo + enddo + endif + enddo + close (irotam) + if (lprint) then + write (iout,'(/a)') 'Parameters of side-chain local geometry' + do i=1,ntyp + nlobi=nlob(i) + if (nlobi.gt.0) then + if (LaTeX) then + write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i),& + ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) + write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') & + 'log h',(bsc(j,i),j=1,nlobi) + write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') & + 'x',((censc(k,j,i),k=1,3),j=1,nlobi) + do k=1,3 + write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') & + ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) + enddo + else + write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) + write (iout,'(a,f10.4,4(16x,f10.4))') & + 'Center ',(bsc(j,i),j=1,nlobi) + write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3),& + j=1,nlobi) + write (iout,'(a)') + endif + endif + enddo + endif +#else +! +! Read scrot parameters for potentials determined from all-atom AM1 calculations +! added by Urszula Kozlowska 07/11/2007 +! +!el Maximum number of SC local term fitting function coefficiants +!el integer,parameter :: maxsccoef=65 + + allocate(sc_parmin(65,ntyp)) !(maxsccoef,ntyp) + + do i=1,ntyp + read (irotam,*,end=112,err=112) + if (i.eq.10) then + read (irotam,*,end=112,err=112) + else + do j=1,65 + read(irotam,*,end=112,err=112) sc_parmin(j,i) + enddo + endif + enddo +! +! Read the parameters of the probability distribution/energy expression +! of the side chains. +! + write (2,*) "Start reading ROTAM_PDB" + do i=1,ntyp + read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3),& + ((blower(k,l,1),l=1,k),k=1,3) + do j=2,nlob(i) + read (irotam_pdb,*,end=112,err=112) bsc(j,i) + read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3),& + ((blower(k,l,j),l=1,k),k=1,3) + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + enddo + enddo + enddo + endif + enddo + close (irotam_pdb) + write (2,*) "End reading ROTAM_PDB" +#endif + close(irotam) + +#ifdef CRYST_TOR +! +! Read torsional parameters in old format +! + allocate(itortyp(ntyp1)) !(-ntyp1:ntyp1) + + read (itorp,*,end=113,err=113) ntortyp,nterm_old + if (lprint)write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + +!el from energy module-------- + allocate(v1(nterm_old,ntortyp,ntortyp)) + allocate(v2(nterm_old,ntortyp,ntortyp)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor) +!el--------------------------- + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)') + do k=1,nterm_old + read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif +#else +! +! Read torsional parameters +! + allocate(itortyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) + read (itorp,*,end=113,err=113) ntortyp +!el from energy module--------- + allocate(nterm(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) + allocate(nlor(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) + + allocate(vlor1(maxlor,-ntortyp:ntortyp,-ntortyp:ntortyp)) !(maxlor,-maxtor:maxtor,-maxtor:maxtor) + allocate(vlor2(maxlor,ntortyp,ntortyp)) + allocate(vlor3(maxlor,ntortyp,ntortyp)) !(maxlor,maxtor,maxtor) + allocate(v0(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) + + allocate(v1(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) + allocate(v2(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) +!el--------------------------- + nterm(:,:,:)=0 + nlor(:,:,:)=0 +!el--------------------------- + + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +! itortyp(ntyp1)=ntortyp +! itortyp(-ntyp1)=-ntortyp + do iblock=1,2 + write (iout,*) 'ntortyp',ntortyp + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + read (itorp,*,end=113,err=113) nterm(i,j,iblock),& + nlor(i,j,iblock) + nterm(-i,-j,iblock)=nterm(i,j,iblock) + nlor(-i,-j,iblock)=nlor(i,j,iblock) + v0ij=0.0d0 + si=-1.0d0 + do k=1,nterm(i,j,iblock) + read (itorp,*,end=113,err=113) kk,v1(k,i,j,iblock),& + v2(k,i,j,iblock) + v1(k,-i,-j,iblock)=v1(k,i,j,iblock) + v2(k,-i,-j,iblock)=-v2(k,i,j,iblock) + v0ij=v0ij+si*v1(k,i,j,iblock) + si=-si +! write(iout,*) i,j,k,iblock,nterm(i,j,iblock) ! +! write(iout,*) v1(k,-i,-j,iblock),v1(k,i,j,iblock),&! +! v2(k,-i,-j,iblock),v2(k,i,j,iblock)! + enddo + do k=1,nlor(i,j,iblock) + read (itorp,*,end=113,err=113) kk,vlor1(k,i,j),& + vlor2(k,i,j),vlor3(k,i,j) + v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) + enddo + v0(i,j,iblock)=v0ij + v0(-i,-j,iblock)=v0ij + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do iblock=1,2 + do i=-ntortyp,ntortyp + do j=-ntortyp,ntortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm(i,j,iblock) + write (iout,'(2(1pe15.5))') v1(k,i,j,iblock),& + v2(k,i,j,iblock) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor(i,j,iblock) + write (iout,'(3(1pe15.5))') & + vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) + enddo + enddo + enddo + enddo + endif +!elwrite (iout,'(/a/)') 'Torsional constants:',vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) +! +! 6/23/01 Read parameters for double torsionals +! +!el from energy module------------ + allocate(v1c(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + allocate(v1s(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) +!(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) + allocate(v2c(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + allocate(v2s(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) + allocate(ntermd_1(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + allocate(ntermd_2(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +!--------------------------------- + + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + read (itordp,'(3a1)',end=114,err=114) t1,t2,t3 +! write (iout,*) "OK onelett", +! & i,j,k,t1,t2,t3 + + if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j) & + .or. t3.ne.toronelet(k)) then + write (iout,*) "Error in double torsional parameter file",& + i,j,k,t1,t2,t3 +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop "Error in double torsional parameter file" + endif + read (itordp,*,end=114,err=114) ntermd_1(i,j,k,iblock),& + ntermd_2(i,j,k,iblock) + ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock) + ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock) + read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) + read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) + read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) + read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) +! Martix of D parameters for one dimesional foureir series + do l=1,ntermd_1(i,j,k,iblock) + v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock) + v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock) + v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock) + v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock) +! write(iout,*) "whcodze" , +! & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock) + enddo + read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k,iblock),& + v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock),& + v2s(m,l,i,j,k,iblock),& + m=1,l-1),l=1,ntermd_2(i,j,k,iblock)) +! Martix of D parameters for two dimesional fourier series + do l=1,ntermd_2(i,j,k,iblock) + do m=1,l-1 + v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock) + v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock) + v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock) + v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock) + enddo!m + enddo!l + enddo!k + enddo!j + enddo!i + enddo!iblock + if (lprint) then + write (iout,*) + write (iout,*) 'Constants for double torsionals' + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,& + ' nsingle',ntermd_1(i,j,k,iblock),& + ' ndouble',ntermd_2(i,j,k,iblock) + write (iout,*) + write (iout,*) 'Single angles:' + do l=1,ntermd_1(i,j,k,iblock) + write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l,& + v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock),& + v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock),& + v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock) + enddo + write (iout,*) + write (iout,*) 'Pairs of angles:' + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') & + l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)) + enddo + write (iout,*) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') & + l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)),& + (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock)) + enddo + write (iout,*) + enddo + enddo + enddo + enddo + endif +#endif +! Read of Side-chain backbone correlation parameters +! Modified 11 May 2012 by Adasko +!CC +! + read (isccor,*,end=119,err=119) nsccortyp + +!el from module energy------------- + allocate(nlor_sccor(nsccortyp,nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) + allocate(vlor1sccor(maxterm_sccor,nsccortyp,nsccortyp)) + allocate(vlor2sccor(maxterm_sccor,nsccortyp,nsccortyp)) + allocate(vlor3sccor(maxterm_sccor,nsccortyp,nsccortyp)) !(maxterm_sccor,20,20) +!----------------------------------- +#ifdef SCCORPDB +!el from module energy------------- + allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) + + read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) + do i=-ntyp,-1 + isccortyp(i)=-isccortyp(-i) + enddo + iscprol=isccortyp(20) +! write (iout,*) 'ntortyp',ntortyp + maxinter=3 +!c maxinter is maximum interaction sites +!el from module energy--------- + allocate(nterm_sccor(-nsccortyp:nsccortyp,-nsccortyp:nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) + allocate(v1sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& + -nsccortyp:nsccortyp)) + allocate(v2sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& + -nsccortyp:nsccortyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) + allocate(v0sccor(maxinter,-nsccortyp:nsccortyp,& + -nsccortyp:nsccortyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) +!----------------------------------- + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=119,err=119) & + nterm_sccor(i,j),nlor_sccor(i,j) + v0ijsccor=0.0d0 + v0ijsccor1=0.0d0 + v0ijsccor2=0.0d0 + v0ijsccor3=0.0d0 + si=-1.0d0 + nterm_sccor(-i,j)=nterm_sccor(i,j) + nterm_sccor(-i,-j)=nterm_sccor(i,j) + nterm_sccor(i,-j)=nterm_sccor(i,j) + do k=1,nterm_sccor(i,j) + read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j),& + v2sccor(k,l,i,j) + if (j.eq.iscprol) then + if (i.eq.isccortyp(10)) then + v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) + else + v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0 & + +v2sccor(k,l,i,j)*dsqrt(0.75d0) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0 & + +v1sccor(k,l,i,j)*dsqrt(0.75d0) + v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) + v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) + v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) + endif + else + if (i.eq.isccortyp(10)) then + v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) + else + if (j.eq.isccortyp(10)) then + v1sccor(k,l,-i,j)=v1sccor(k,l,i,j) + v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j) + else + v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) + v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) + v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) + v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) + endif + endif + endif + v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) + v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j) + v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j) + v0ijsccor3=v0ijsccor+si*v1sccor(k,l,-i,-j) + si=-si + enddo + do k=1,nlor_sccor(i,j) + read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j),& + vlor2sccor(k,i,j),vlor3sccor(k,i,j) + v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ & + (1+vlor3sccor(k,i,j)**2) + enddo + v0sccor(l,i,j)=v0ijsccor + v0sccor(l,-i,j)=v0ijsccor1 + v0sccor(l,i,-j)=v0ijsccor2 + v0sccor(l,-i,-j)=v0ijsccor3 + enddo + enddo + enddo + close (isccor) +#else +!el from module energy------------- + allocate(isccortyp(ntyp)) !(-ntyp:ntyp) + + read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) +! write (iout,*) 'ntortyp',ntortyp + maxinter=3 +!c maxinter is maximum interaction sites +!el from module energy--------- + allocate(nterm_sccor(nsccortyp,nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) + allocate(v1sccor(maxterm_sccor,maxinter,nsccortyp,nsccortyp)) + allocate(v2sccor(maxterm_sccor,maxinter,nsccortyp,nsccortyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) + allocate(v0sccor(maxinter,nsccortyp,nsccortyp)) !???(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) +!----------------------------------- + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=119,err=119) & + nterm_sccor(i,j),nlor_sccor(i,j) + v0ijsccor=0.0d0 + si=-1.0d0 + + do k=1,nterm_sccor(i,j) + read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j),& + v2sccor(k,l,i,j) + v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) + si=-si + enddo + do k=1,nlor_sccor(i,j) + read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j),& + vlor2sccor(k,i,j),vlor3sccor(k,i,j) + v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ & + (1+vlor3sccor(k,i,j)**2) + enddo + v0sccor(l,i,j)=v0ijsccor !el ,iblock + enddo + enddo + enddo + close (isccor) + +#endif + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,nsccortyp + do j=1,nsccortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm_sccor(i,j) + write (iout,'(2(1pe15.5))') v1sccor(k,l,i,j),v2sccor(k,l,i,j) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor_sccor(i,j) + write (iout,'(3(1pe15.5))') & + vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) + enddo + enddo + enddo + endif + +! +! 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +! interaction energy of the Gly, Ala, and Pro prototypes. +! + + if (lprint) then + write (iout,*) + write (iout,*) "Coefficients of the cumulants" + endif + read (ifourier,*) nloctyp +!write(iout,*) "nloctyp",nloctyp +!el from module energy------- + allocate(b1(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) + allocate(b2(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) + allocate(b1tilde(2,-nloctyp+1:nloctyp+1)) !(2,-maxtor:maxtor) + allocate(cc(2,2,-nloctyp-1:nloctyp+1)) + allocate(dd(2,2,-nloctyp-1:nloctyp+1)) + allocate(ee(2,2,-nloctyp-1:nloctyp+1)) + allocate(ctilde(2,2,-nloctyp-1:nloctyp+1)) + allocate(dtilde(2,2,-nloctyp-1:nloctyp+1)) !(2,2,-maxtor:maxtor) +! el + b1(1,:)=0.0d0 + b1(2,:)=0.0d0 +!-------------------------------- + + do i=0,nloctyp-1 + read (ifourier,*,end=115,err=115) + read (ifourier,*,end=115,err=115) (bN(ii),ii=1,13) + if (lprint) then + write (iout,*) 'Type',i + write (iout,'(a,i2,a,f10.5)') ('bN(',ii,')=',bN(ii),ii=1,13) + endif + B1(1,i) = bN(3) + B1(2,i) = bN(5) + B1(1,-i) = bN(3) + B1(2,-i) = -bN(5) +! b1(1,i)=0.0d0 +! b1(2,i)=0.0d0 + B1tilde(1,i) = bN(3) + B1tilde(2,i) =-bN(5) + B1tilde(1,-i) =-bN(3) + B1tilde(2,-i) =bN(5) +! b1tilde(1,i)=0.0d0 +! b1tilde(2,i)=0.0d0 + B2(1,i) = bN(2) + B2(2,i) = bN(4) + B2(1,-i) =bN(2) + B2(2,-i) =-bN(4) + +! b2(1,i)=0.0d0 +! b2(2,i)=0.0d0 + CC(1,1,i)= bN(7) + CC(2,2,i)=-bN(7) + CC(2,1,i)= bN(9) + CC(1,2,i)= bN(9) + CC(1,1,-i)= bN(7) + CC(2,2,-i)=-bN(7) + CC(2,1,-i)=-bN(9) + CC(1,2,-i)=-bN(9) +! CC(1,1,i)=0.0d0 +! CC(2,2,i)=0.0d0 +! CC(2,1,i)=0.0d0 +! CC(1,2,i)=0.0d0 + Ctilde(1,1,i)=bN(7) + Ctilde(1,2,i)=bN(9) + Ctilde(2,1,i)=-bN(9) + Ctilde(2,2,i)=bN(7) + Ctilde(1,1,-i)=bN(7) + Ctilde(1,2,-i)=-bN(9) + Ctilde(2,1,-i)=bN(9) + Ctilde(2,2,-i)=bN(7) + +! Ctilde(1,1,i)=0.0d0 +! Ctilde(1,2,i)=0.0d0 +! Ctilde(2,1,i)=0.0d0 +! Ctilde(2,2,i)=0.0d0 + DD(1,1,i)= bN(6) + DD(2,2,i)=-bN(6) + DD(2,1,i)= bN(8) + DD(1,2,i)= bN(8) + DD(1,1,-i)= bN(6) + DD(2,2,-i)=-bN(6) + DD(2,1,-i)=-bN(8) + DD(1,2,-i)=-bN(8) +! DD(1,1,i)=0.0d0 +! DD(2,2,i)=0.0d0 +! DD(2,1,i)=0.0d0 +! DD(1,2,i)=0.0d0 + Dtilde(1,1,i)=bN(6) + Dtilde(1,2,i)=bN(8) + Dtilde(2,1,i)=-bN(8) + Dtilde(2,2,i)=bN(6) + Dtilde(1,1,-i)=bN(6) + Dtilde(1,2,-i)=-bN(8) + Dtilde(2,1,-i)=bN(8) + Dtilde(2,2,-i)=bN(6) + +! Dtilde(1,1,i)=0.0d0 +! Dtilde(1,2,i)=0.0d0 +! Dtilde(2,1,i)=0.0d0 +! Dtilde(2,2,i)=0.0d0 + EE(1,1,i)= bN(10)+bN(11) + EE(2,2,i)=-bN(10)+bN(11) + EE(2,1,i)= bN(12)-bN(13) + EE(1,2,i)= bN(12)+bN(13) + EE(1,1,-i)= bN(10)+bN(11) + EE(2,2,-i)=-bN(10)+bN(11) + EE(2,1,-i)=-bN(12)+bN(13) + EE(1,2,-i)=-bN(12)-bN(13) + +! ee(1,1,i)=1.0d0 +! ee(2,2,i)=1.0d0 +! ee(2,1,i)=0.0d0 +! ee(1,2,i)=0.0d0 +! ee(2,1,i)=ee(1,2,i) + enddo + if (lprint) then + do i=1,nloctyp + write (iout,*) 'Type',i + write (iout,*) 'B1' + write(iout,*) B1(1,i),B1(2,i) + write (iout,*) 'B2' + write(iout,*) B2(1,i),B2(2,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) + enddo + enddo + endif +! +! Read electrostatic-interaction parameters +! + + if (lprint) then + write (iout,*) + write (iout,'(/a)') 'Electrostatic interaction constants:' + write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') & + 'IT','JT','APP','BPP','AEL6','AEL3' + endif + read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) + close (ielep) + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + app (i,j)=epp(i,j)*rri*rri + bpp (i,j)=-2.0D0*epp(i,j)*rri + ael6(i,j)=elpp6(i,j)*4.2D0**6 + ael3(i,j)=elpp3(i,j)*4.2D0**3 +! lprint=.true. + if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j),& + ael6(i,j),ael3(i,j) +! lprint=.false. + enddo + enddo +! +! Read side-chain interaction parameters. +! +!el from module energy - COMMON.INTERACT------- + allocate(eps(ntyp,ntyp),sigmaii(ntyp,ntyp),rs0(ntyp,ntyp)) !(ntyp,ntyp) + allocate(augm(ntyp,ntyp)) !(ntyp,ntyp) + allocate(eps_scp(ntyp,2),rscp(ntyp,2)) !(ntyp,2) + allocate(sigma0(ntyp),rr0(ntyp),sigii(ntyp)) !(ntyp) + allocate(chip(ntyp1),alp(ntyp1)) !(ntyp) + + augm(:,:)=0.0D0 + chip(:)=0.0D0 + alp(:)=0.0D0 + sigma0(:)=0.0D0 + sigii(:)=0.0D0 + rr0(:)=0.0D0 + +!-------------------------------- + + read (isidep,*,end=117,err=117) ipot,expon + if (ipot.lt.1 .or. ipot.gt.5) then + write (iout,'(2a)') 'Error while reading SC interaction',& + 'potential file - unknown potential type.' +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + endif + expon2=expon/2 + if(me.eq.king) & + write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot),& + ', exponents are ',expon,2*expon +! goto (10,20,30,30,40) ipot + select case(ipot) +!----------------------- LJ potential --------------------------------- + case (1) +! 10 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& + read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& + (sigma0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJ potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,a)') 'residue','sigma' + write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) + endif +! goto 50 +!----------------------- LJK potential -------------------------------- + case(2) +! 20 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& + read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& + (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJK potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' + write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i),& + i=1,ntyp) + endif +! goto 50 +!---------------------- GB or BP potential ----------------------------- + case(3:4) +! 30 do i=1,ntyp + do i=1,ntyp + read (isidep,*,end=117,err=117)(eps(i,j),j=i,ntyp) + enddo + read (isidep,*,end=117,err=117)(sigma0(i),i=1,ntyp) + read (isidep,*,end=117,err=117)(sigii(i),i=1,ntyp) + read (isidep,*,end=117,err=117)(chip(i),i=1,ntyp) + read (isidep,*,end=117,err=117)(alp(i),i=1,ntyp) +! For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2',& + ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i),& + chip(i),alp(i),i=1,ntyp) + endif +! goto 50 +!--------------------- GBV potential ----------------------------------- + case(5) +! 40 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& + read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& + (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp),& + (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the GBV potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ',& + 's||/s_|_^2',' chip ',' alph ' + write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i),& + sigii(i),chip(i),alp(i),i=1,ntyp) + endif + case default + write(iout,*)"Wrong ipot" +! 50 continue + end select + continue + close (isidep) +!----------------------------------------------------------------------- +! Calculate the "working" parameters of SC interactions. + +!el from module energy - COMMON.INTERACT------- + allocate(aa(ntyp1,ntyp1),bb(ntyp1,ntyp1),chi(ntyp1,ntyp1)) !(ntyp,ntyp) + allocate(sigma(0:ntyp1,0:ntyp1),r0(ntyp1,ntyp1)) !(0:ntyp1,0:ntyp1) + aa(:,:)=0.0D0 + bb(:,:)=0.0D0 + chi(:,:)=0.0D0 + sigma(:,:)=0.0D0 + r0(:,:)=0.0D0 + +!-------------------------------- + + do i=2,ntyp + do j=1,i-1 + eps(i,j)=eps(j,i) + enddo + enddo + do i=1,ntyp + do j=i,ntyp + sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) + sigma(j,i)=sigma(i,j) + rs0(i,j)=dwa16*sigma(i,j) + rs0(j,i)=rs0(i,j) + enddo + enddo + if (lprint) write (iout,'(/a/10x,7a/72(1h-))') & + 'Working parameters of the SC interactions:',& + ' a ',' b ',' augm ',' sigma ',' r0 ',& + ' chi1 ',' chi2 ' + do i=1,ntyp + do j=i,ntyp + epsij=eps(i,j) + if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + rrij=sigma(i,j) + else + rrij=rr0(i)+rr0(j) + endif + r0(i,j)=rrij + r0(j,i)=rrij + rrij=rrij**expon + epsij=eps(i,j) + sigeps=dsign(1.0D0,epsij) + epsij=dabs(epsij) + aa(i,j)=epsij*rrij*rrij + bb(i,j)=-sigeps*epsij*rrij + aa(j,i)=aa(i,j) + bb(j,i)=bb(i,j) + if (ipot.gt.2) then + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +! if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +! else +! sigmaii(i,j)=r0(i,j) +! sigmaii(j,i)=r0(i,j) +! endif +!d write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +! augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') & + restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j),& + sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + endif + enddo + enddo + + allocate(aad(ntyp,2),bad(ntyp,2)) !(ntyp,2) + bad(:,:)=0.0D0 + +#ifdef OLDSCP +! +! Define the SC-p interaction constants (hard-coded; old style) +! + do i=1,ntyp +! "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +! helix formation) +! aad(i,1)=0.3D0*4.0D0**12 +! Following line for constants currently implemented +! "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +! aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +! "Soft" SC-p repulsion + bad(i,1)=0.0D0 +! Following line for constants currently implemented +! aad(i,1)=0.3D0*4.0D0**6 +! "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +! bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +! aad(i,1)=0.0D0 +! aad(i,2)=0.0D0 +! bad(i,1)=1228.8D0 +! bad(i,2)=1228.8D0 + enddo +#else +! +! 8/9/01 Read the SC-p interaction constants from file +! + do i=1,ntyp + read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo +! lprint=.true. + if (lprint) then + write (iout,*) "Parameters of SC-p interactions:" + do i=1,ntyp + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1),& + eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +! lprint=.false. +#endif +! +! Define the constants of the disulfide bridge +! + ebr=-5.50D0 +! +! Old arbitrary potential - commented out. +! +! dbr= 4.20D0 +! fbr= 3.30D0 +! +! Constants of the disulfide-bond potential determined based on the RHF/6-31G** +! energy surface of diethyl disulfide. +! A. Liwo and U. Kozlowska, 11/24/03 +! + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 +! akcm=0.0d0 +! akth=0.0d0 +! akct=0.0d0 +! v1ss=0.0d0 +! v2ss=0.0d0 +! v3ss=0.0d0 + + if(me.eq.king) then + write (iout,'(/a)') "Disulfide bridge parameters:" + write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr + write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm + write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct + write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,& + ' v3ss:',v3ss + endif + return + 111 write (iout,*) "Error reading bending energy parameters." + goto 999 + 112 write (iout,*) "Error reading rotamer energy parameters." + goto 999 + 113 write (iout,*) "Error reading torsional energy parameters." + goto 999 + 114 write (iout,*) "Error reading double torsional energy parameters." + goto 999 + 115 write (iout,*) & + "Error reading cumulant (multibody energy) parameters." + goto 999 + 116 write (iout,*) "Error reading electrostatic energy parameters." + goto 999 + 117 write (iout,*) "Error reading side chain interaction parameters." + goto 999 + 118 write (iout,*) "Error reading SCp interaction parameters." + goto 999 + 119 write (iout,*) "Error reading SCCOR parameters" + 999 continue +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + return + end subroutine parmread +#endif +!----------------------------------------------------------------------------- +! printmat.f +!----------------------------------------------------------------------------- + subroutine printmat(ldim,m,n,iout,key,a) + + integer :: n,ldim + character(len=3),dimension(n) :: key + real(kind=8),dimension(ldim,n) :: a +!el local variables + integer :: i,j,k,m,iout,nlim + + do 1 i=1,n,8 + nlim=min0(i+7,n) + write (iout,1000) (key(k),k=i,nlim) + write (iout,1020) + 1000 format (/5x,8(6x,a3)) + 1020 format (/80(1h-)/) + do 2 j=1,n + write (iout,1010) key(j),(a(j,k),k=i,nlim) + 2 continue + 1 continue + 1010 format (a3,2x,8(f9.4)) + return + end subroutine printmat +!----------------------------------------------------------------------------- +! readpdb.F +!----------------------------------------------------------------------------- + subroutine readpdb +! Read the PDB file and convert the peptide geometry into virtual-chain +! geometry. + use geometry_data + use energy_data, only: itype + use control_data + use compare_data + use MPI_data + use control, only: rescode +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.LOCAL' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.NAMES' +! include 'COMMON.CONTROL' +! include 'COMMON.DISTFIT' +! include 'COMMON.SETUP' + integer :: i,j,ibeg,ishift1,ires,iii,ires_old,ishift!,ity!,& +! ishift_pdb + logical :: lprn=.true.,fail + real(kind=8),dimension(3) :: e1,e2,e3 + real(kind=8) :: dcj,efree_temp + character(len=3) :: seq,res + character(len=5) :: atom + character(len=80) :: card + real(kind=8),dimension(3,20) :: sccor + integer :: kkk,lll,icha,kupa !rescode, + real(kind=8) :: cou +!el local varables + integer,dimension(2,maxres/3) :: hfrag_alloc + integer,dimension(4,maxres/3) :: bfrag_alloc + real(kind=8),dimension(3,maxres2+2,maxperm) :: cref_alloc !(3,maxres2+2,maxperm) + + efree_temp=0.0d0 + ibeg=1 + ishift1=0 + ishift=0 +! write (2,*) "UNRES_PDB",unres_pdb + ires=0 + ires_old=0 + nres=0 + iii=0 + lsecondary=.false. + nhfrag=0 + nbfrag=0 +!----------------------------- + allocate(hfrag(2,maxres/3)) !(2,maxres/3) + allocate(bfrag(4,maxres/3)) !(4,maxres/3) + + do i=1,100000 + read (ipdbin,'(a80)',end=10) card +! write (iout,'(a)') card + if (card(:5).eq.'HELIX') then + nhfrag=nhfrag+1 + lsecondary=.true. + read(card(22:25),*) hfrag(1,nhfrag) + read(card(34:37),*) hfrag(2,nhfrag) + endif + if (card(:5).eq.'SHEET') then + nbfrag=nbfrag+1 + lsecondary=.true. + read(card(24:26),*) bfrag(1,nbfrag) + read(card(35:37),*) bfrag(2,nbfrag) +!rc---------------------------------------- +!rc to be corrected !!! + bfrag(3,nbfrag)=bfrag(1,nbfrag) + bfrag(4,nbfrag)=bfrag(2,nbfrag) +!rc---------------------------------------- + endif + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +! End current chain + ires_old=ires+1 + ishift1=ishift1+1 + itype(ires_old)=ntyp1 + ibeg=2 +! write (iout,*) "Chain ended",ires,ishift,ires_old + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires,iii,sccor) + endif + iii=0 + endif +! Read free energy + if (index(card,"FREE ENERGY").gt.0) read(card(35:),*) efree_temp +! Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(12:16),*) atom +! write (iout,*) "! ",atom," !",ires +! if (atom.eq.'CA' .or. atom.eq.'CH3') then + read (card(23:26),*) ires + read (card(18:20),'(a3)') res +! write (iout,*) "ires",ires,ires-ishift+ishift1, +! & " ires_old",ires_old +! write (iout,*) "ishift",ishift," ishift1",ishift1 +! write (iout,*) "IRES",ires-ishift+ishift1,ires_old + if (ires-ishift+ishift1.ne.ires_old) then +! Calculate the CM of the preceding residue. +! if (ibeg.eq.0) call sccenter(ires,iii,sccor) + if (ibeg.eq.0) then +! write (iout,*) "Calculating sidechain center iii",iii + if (unres_pdb) then + do j=1,3 + dc(j,ires+nres)=sccor(j,iii) + enddo + else + call sccenter(ires_old,iii,sccor) + endif + iii=0 + endif +! Start new residue. + if (res.eq.'Cl-' .or. res.eq.'Na+') then + ires=ires_old + cycle + else if (ibeg.eq.1) then + write (iout,*) "BEG ires",ires + ishift=ires-1 + if (res.ne.'GLY' .and. res.ne. 'ACE') then + ishift=ishift-1 + itype(1)=ntyp1 + endif + ires=ires-ishift+ishift1 + ires_old=ires +! write (iout,*) "ishift",ishift," ires",ires,& +! " ires_old",ires_old + ibeg=0 + else if (ibeg.eq.2) then +! Start a new chain + ishift=-ires_old+ires-1 !!!!! + ishift1=ishift1-1 !!!!! +! write (iout,*) "New chain started",ires,ishift,ishift1,"!" + ires=ires-ishift+ishift1 + ires_old=ires + ibeg=0 + else + ishift=ishift-(ires-ishift+ishift1-ires_old-1) + ires=ires-ishift+ishift1 + ires_old=ires + endif + if (res.eq.'ACE' .or. res.eq.'NHE') then + itype(ires)=10 + else + itype(ires)=rescode(ires,res,0) + endif + else + ires=ires-ishift+ishift1 + endif +! write (iout,*) "ires_old",ires_old," ires",ires + if (card(27:27).eq."A" .or. card(27:27).eq."B") then +! ishift1=ishift1+1 + endif +! write (2,*) "ires",ires," res ",res!," ity"!,ity + if (atom.eq.'CA' .or. atom.eq.'CH3' .or. & + res.eq.'NHE'.and.atom(:2).eq.'HN') then + read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) +! write (iout,*) "backbone ",atom +#ifdef DEBUG + write (iout,'(2i3,2x,a,3f8.3)') & + ires,itype(ires),res,(c(j,ires),j=1,3) +#endif + iii=iii+1 + do j=1,3 + sccor(j,iii)=c(j,ires) + enddo +! write (*,*) card(23:27),ires,itype(ires) + else if (atom.ne.'O'.and.atom(1:1).ne.'H' .and. & + atom.ne.'N' .and. atom.ne.'C' .and. & + atom(:2).ne.'1H' .and. atom(:2).ne.'2H' .and. & + atom.ne.'OXT' .and. atom(:2).ne.'3H') then +! write (iout,*) "sidechain ",atom + iii=iii+1 + read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) + endif + endif + enddo + 10 write (iout,'(a,i5)') ' Number of residues found: ',ires + if (ires.eq.0) return +! Calculate dummy residue coordinates inside the "chain" of a multichain +! system + nres=ires + do i=2,nres-1 +! write (iout,*) i,itype(i) + if (itype(i).eq.ntyp1) then +! write (iout,*) "dummy",i,itype(i) + do j=1,3 + c(j,i)=((c(j,i-1)+c(j,i+1))/2+2*c(j,i-1)-c(j,i-2))/2 +! c(j,i)=(c(j,i-1)+c(j,i+1))/2 + dc(j,i)=c(j,i) + enddo + endif + enddo +! Calculate the CM of the last side chain. + if (iii.gt.0) then + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires,iii,sccor) + endif + endif +! nres=ires + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=ntyp1 + if (unres_pdb) then +! 2/15/2013 by Adam: corrected insertion of the last dummy residue + call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,nres)=c(j,nres-1)-3.8d0*e2(j) + enddo + else + do j=1,3 + dcj=c(j,nres-2)-c(j,nres-3) + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + endif +!el kontrola nres w pliku inputowym WHAM-a w porownaniu z wartoscia wczytana z pliku pdb +#ifdef WHAM_RUN + if (nres.ne.nres0) then + write (iout,*) "Error: wrong parameter value: NRES=",nres,& + " NRES0=",nres0 + stop "Error nres value in WHAM input" + endif +#endif +!--------------------------------- +!el reallocate tables +! do i=1,maxres/3 +! do j=1,2 +! hfrag_alloc(j,i)=hfrag(j,i) +! enddo +! do j=1,4 +! bfrag_alloc(j,i)=bfrag(j,i) +! enddo +! enddo + +! deallocate(hfrag) +! deallocate(bfrag) +! allocate(hfrag(2,nres/3)) !(2,maxres/3) +!el allocate(hfrag(2,nhfrag)) !(2,maxres/3) +!el allocate(bfrag(4,nbfrag)) !(4,maxres/3) +! allocate(bfrag(4,nres/3)) !(4,maxres/3) + +! do i=1,nhfrag +! do j=1,2 +! hfrag(j,i)=hfrag_alloc(j,i) +! enddo +! enddo +! do i=1,nbfrag +! do j=1,4 +! bfrag(j,i)=bfrag_alloc(j,i) +! enddo +! enddo +!el end reallocate tables +!--------------------------------- + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.ntyp1) then + nsup=nsup-1 + nstart_sup=2 + if (unres_pdb) then +! 2/15/2013 by Adam: corrected insertion of the first dummy residue + call refsys(2,3,4,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,1)=c(j,2)-3.8d0*e2(j) + enddo + else + do j=1,3 + dcj=c(j,4)-c(j,3) + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif + endif +! Copy the coordinates to reference coordinates +! do i=1,2*nres +! do j=1,3 +! cref(j,i)=c(j,i) +! enddo +! enddo +! Calculate internal coordinates. + if (lprn) then + write (iout,'(/a)') & + "Cartesian coordinates of the reference structure" + write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & + "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" + do ires=1,nres + write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & + restyp(itype(ires)),ires,(c(j,ires),j=1,3),& + (c(j,ires+nres),j=1,3) + enddo + endif +! znamy już nres wiec mozna alokowac tablice +! Calculate internal coordinates. + if(me.eq.king.or..not.out1file)then + write (iout,'(a)') & + "Backbone and SC coordinates as read from the PDB" + do ires=1,nres + write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') & + ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3),& + (c(j,nres+ires),j=1,3) + enddo + endif + + if(.not.allocated(vbld)) then + allocate(vbld(2*nres)) + do i=1,2*nres + vbld(i)=0.d0 + enddo + endif + if(.not.allocated(vbld_inv)) then + allocate(vbld_inv(2*nres)) + do i=1,2*nres + vbld_inv(i)=0.d0 + enddo + endif +!!!el + if(.not.allocated(theta)) then + allocate(theta(nres+2)) + theta(:)=0.0d0 + endif + + if(.not.allocated(phi)) allocate(phi(nres+2)) + if(.not.allocated(alph)) allocate(alph(nres+2)) + if(.not.allocated(omeg)) allocate(omeg(nres+2)) + if(.not.allocated(thetaref)) allocate(thetaref(nres+2)) + if(.not.allocated(phiref)) allocate(phiref(nres+2)) + if(.not.allocated(costtab)) allocate(costtab(nres)) + if(.not.allocated(sinttab)) allocate(sinttab(nres)) + if(.not.allocated(cost2tab)) allocate(cost2tab(nres)) + if(.not.allocated(sint2tab)) allocate(sint2tab(nres)) + if(.not.allocated(xxref)) allocate(xxref(nres)) + if(.not.allocated(yyref)) allocate(yyref(nres)) + if(.not.allocated(zzref)) allocate(zzref(nres)) !(maxres) + if(.not.allocated(dc_norm)) then +! if(.not.allocated(dc_norm)) allocate(dc_norm(3,0:2*nres+2)) + allocate(dc_norm(3,0:2*nres+2)) + dc_norm(:,:)=0.d0 + endif + + call int_from_cart(.true.,.false.) + call sc_loc_geom(.false.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo +! do i=1,2*nres +! vbld_inv(i)=0.d0 +! vbld(i)=0.d0 +! enddo + + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +! write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3),& +! vbld_inv(i+nres) + enddo +! call chainbuild +! Copy the coordinates to reference coordinates +! Splits to single chain if occurs + +! do i=1,2*nres +! do j=1,3 +! cref(j,i,cou)=c(j,i) +! enddo +! enddo +! + if(.not.allocated(cref)) allocate(cref(3,2*nres+2,maxperm)) !(3,maxres2+2,maxperm) + if(.not.allocated(chain_rep)) allocate(chain_rep(3,2*nres+2,maxsym)) !(3,maxres2+2,maxsym) + if(.not.allocated(tabperm)) allocate(tabperm(maxperm,maxsym)) !(maxperm,maxsym) +!----------------------------- + kkk=1 + lll=0 + cou=1 + do i=1,nres + lll=lll+1 +!c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) + if (i.gt.1) then + if ((itype(i-1).eq.ntyp1).and.(i.gt.2)) then + chain_length=lll-1 + kkk=kkk+1 +! write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) + lll=1 + endif + endif + do j=1,3 + cref(j,i,cou)=c(j,i) + cref(j,i+nres,cou)=c(j,i+nres) + if (i.le.nres) then + chain_rep(j,lll,kkk)=c(j,i) + chain_rep(j,lll+nres,kkk)=c(j,i+nres) + endif + enddo + enddo + write (iout,*) chain_length + if (chain_length.eq.0) chain_length=nres + do j=1,3 + chain_rep(j,chain_length,symetr)=chain_rep(j,chain_length,1) + chain_rep(j,chain_length+nres,symetr) & + =chain_rep(j,chain_length+nres,1) + enddo +! diagnostic +! write (iout,*) "spraw lancuchy",chain_length,symetr +! do i=1,4 +! do kkk=1,chain_length +! write (iout,*) itype(kkk),(chain_rep(j,kkk,i), j=1,3) +! enddo +! enddo +! enddiagnostic +! makes copy of chains + write (iout,*) "symetr", symetr + + if (symetr.gt.1) then + call permut(symetr) + nperm=1 + do i=1,symetr + nperm=nperm*i + enddo + do i=1,nperm + write(iout,*) (tabperm(i,kkk),kkk=1,4) + enddo + do i=1,nperm + cou=0 + do kkk=1,symetr + icha=tabperm(i,kkk) +! write (iout,*) i,icha + do lll=1,chain_length + cou=cou+1 + if (cou.le.nres) then + do j=1,3 + kupa=mod(lll,chain_length) + iprzes=(kkk-1)*chain_length+lll + if (kupa.eq.0) kupa=chain_length +! write (iout,*) "kupa", kupa + cref(j,iprzes,i)=chain_rep(j,kupa,icha) + cref(j,iprzes+nres,i)=chain_rep(j,kupa+nres,icha) + enddo + endif + enddo + enddo + enddo + endif +!-koniec robienia kopii +! diag + do kkk=1,nperm + write (iout,*) "nowa struktura", nperm + do i=1,nres + write (iout,110) restyp(itype(i)),i,cref(1,i,kkk),& + cref(2,i,kkk),& + cref(3,i,kkk),cref(1,nres+i,kkk),& + cref(2,nres+i,kkk),cref(3,nres+i,kkk) + enddo + 100 format (//' alpha-carbon coordinates ',& + ' centroid coordinates'/ & + ' ', 6X,'X',11X,'Y',11X,'Z', & + 10X,'X',11X,'Y',11X,'Z') + 110 format (a,'(',i3,')',6f12.5) + + enddo +!c enddiag + do j=1,nbfrag + do i=1,4 + bfrag(i,j)=bfrag(i,j)-ishift + enddo + enddo + + do j=1,nhfrag + do i=1,2 + hfrag(i,j)=hfrag(i,j)-ishift + enddo + enddo + ishift_pdb=ishift + + return + end subroutine readpdb +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + subroutine read_control +! +! Read contorl data +! +! use geometry_data + use comm_machsw + use energy_data + use control_data + use compare_data + use MCM_data + use map_data + use csa_data + use MD_data + use MPI_data + use random, only: random_init +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MP + use prng, only:prng_restart + include 'mpif.h' + logical :: OKRandom!, prng_restart + real(kind=8) :: r1 +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.THREAD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.MCM' +! include 'COMMON.MAP' +! include 'COMMON.HEADER' +! include 'COMMON.CSA' +! include 'COMMON.CHAIN' +! include 'COMMON.MUCA' +! include 'COMMON.MD' +! include 'COMMON.FFIELD' +! include 'COMMON.INTERACT' +! include 'COMMON.SETUP' +!el integer :: KDIAG,ICORFL,IXDR +!el COMMON /MACHSW/ KDIAG,ICORFL,IXDR + character(len=8),dimension(0:3) :: diagmeth = reshape((/'Library ',& + 'EVVRSP ','Givens ','Jacobi '/),shape(diagmeth)) +! character(len=80) :: ucase + character(len=640) :: controlcard + + real(kind=8) :: seed,rmsdbc,rmsdbc1max,rmsdbcm,drms,timem!,& + + + nglob_csa=0 + eglob_csa=1d99 + nmin_csa=0 + read (INP,'(a)') titel + call card_concat(controlcard,.true.) +! out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0 +! print *,"Processor",me," fg_rank",fg_rank," out1file",out1file + call reada(controlcard,'SEED',seed,0.0D0) + call random_init(seed) +! Set up the time limit (caution! The time must be input in minutes!) + read_cart=index(controlcard,'READ_CART').gt.0 + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + call readi(controlcard,'SYM',symetr,1) + call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours + unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 + call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes + call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) + call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) + call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) + call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) + call reada(controlcard,'DRMS',drms,0.1D0) + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc + write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 + write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max + write (iout,'(a,f10.1)')'DRMS = ',drms + write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm + write (iout,'(a,f10.1)') 'Time limit (min):',timlim + endif + call readi(controlcard,'NZ_START',nz_start,0) + call readi(controlcard,'NZ_END',nz_end,0) + call readi(controlcard,'IZ_SC',iz_sc,0) + timlim=60.0D0*timlim + safety = 60.0d0*safety + timem=timlim + modecalc=0 + call reada(controlcard,"T_BATH",t_bath,300.0d0) + minim=(index(controlcard,'MINIMIZE').gt.0) + dccart=(index(controlcard,'CART').gt.0) + overlapsc=(index(controlcard,'OVERLAP').gt.0) + overlapsc=.not.overlapsc + searchsc=(index(controlcard,'NOSEARCHSC').gt.0) + searchsc=.not.searchsc + sideadd=(index(controlcard,'SIDEADD').gt.0) + energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) + outpdb=(index(controlcard,'PDBOUT').gt.0) + outmol2=(index(controlcard,'MOL2OUT').gt.0) + pdbref=(index(controlcard,'PDBREF').gt.0) + refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0) + indpdb=index(controlcard,'PDBSTART') + extconf=(index(controlcard,'EXTCONF').gt.0) + call readi(controlcard,'IPRINT',iprint,0) + call readi(controlcard,'MAXGEN',maxgen,10000) + call readi(controlcard,'MAXOVERLAP',maxoverlap,1000) + call readi(controlcard,"KDIAG",kdiag,0) + call readi(controlcard,"RESCALE_MODE",rescale_mode,2) + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) & + write (iout,*) "RESCALE_MODE",rescale_mode + split_ene=index(controlcard,'SPLIT_ENE').gt.0 + if (index(controlcard,'REGULAR').gt.0.0D0) then + call reada(controlcard,'WEIDIS',weidis,0.1D0) + modecalc=1 + refstr=.true. + endif + if (index(controlcard,'CHECKGRAD').gt.0) then + modecalc=5 + if (index(controlcard,'CART').gt.0) then + icheckgrad=1 + elseif (index(controlcard,'CARINT').gt.0) then + icheckgrad=2 + else + icheckgrad=3 + endif + elseif (index(controlcard,'THREAD').gt.0) then + modecalc=2 + call readi(controlcard,'THREAD',nthread,0) + if (nthread.gt.0) then + call reada(controlcard,'WEIDIS',weidis,0.1D0) + else + if (fg_rank.eq.0) & + write (iout,'(a)')'A number has to follow the THREAD keyword.' + stop 'Error termination in Read_Control.' + endif + else if (index(controlcard,'MCMA').gt.0) then + modecalc=3 + else if (index(controlcard,'MCEE').gt.0) then + modecalc=6 + else if (index(controlcard,'MULTCONF').gt.0) then + modecalc=4 + else if (index(controlcard,'MAP').gt.0) then + modecalc=7 + call readi(controlcard,'MAP',nmap,0) + else if (index(controlcard,'CSA').gt.0) then + modecalc=8 +!rc else if (index(controlcard,'ZSCORE').gt.0) then +!rc +!rc ZSCORE is rm from UNRES, modecalc=9 is available +!rc +!rc modecalc=9 +!fcm else if (index(controlcard,'MCMF').gt.0) then +!fmc modecalc=10 + else if (index(controlcard,'SOFTREG').gt.0) then + modecalc=11 + else if (index(controlcard,'CHECK_BOND').gt.0) then + modecalc=-1 + else if (index(controlcard,'TEST').gt.0) then + modecalc=-2 + else if (index(controlcard,'MD').gt.0) then + modecalc=12 + else if (index(controlcard,'RE ').gt.0) then + modecalc=14 + endif + + lmuca=index(controlcard,'MUCA').gt.0 + call readi(controlcard,'MUCADYN',mucadyn,0) + call readi(controlcard,'MUCASMOOTH',muca_smooth,0) + if (lmuca .and. (me.eq.king .or. .not.out1file )) & + then + write (iout,*) 'MUCADYN=',mucadyn + write (iout,*) 'MUCASMOOTH=',muca_smooth + endif + + iscode=index(controlcard,'ONE_LETTER') + indphi=index(controlcard,'PHI') + indback=index(controlcard,'BACK') + iranconf=index(controlcard,'RAND_CONF') + i2ndstr=index(controlcard,'USE_SEC_PRED') + gradout=index(controlcard,'GRADOUT').gt.0 + gnorm_check=index(controlcard,'GNORM_CHECK').gt.0 + call reada(controlcard,'DISTCHAINMAX',distchainmax,5.0d0) + if (me.eq.king .or. .not.out1file ) & + write (iout,*) "DISTCHAINMAX",distchainmax + + if(me.eq.king.or..not.out1file) & + write (iout,'(2a)') diagmeth(kdiag),& + ' routine used to diagonalize matrices.' + return + end subroutine read_control +!----------------------------------------------------------------------------- + subroutine read_REMDpar +! +! Read REMD settings +! +! use control +! use energy +! use geometry + use REMD_data + use MPI_data + use control_data, only:out1file +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.MD' + use MD_data +!el #ifndef LANG0 +!el include 'COMMON.LANGEVIN' +!el #else +!el include 'COMMON.LANGEVIN.lang0' +!el #endif +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.REMD' +! include 'COMMON.CONTROL' +! include 'COMMON.SETUP' +! character(len=80) :: ucase + character(len=320) :: controlcard + character(len=3200) :: controlcard1 + integer :: iremd_m_total +!el local variables + integer :: i +! real(kind=8) :: var,ene + + if(me.eq.king.or..not.out1file) & + write (iout,*) "REMD setup" + + call card_concat(controlcard,.true.) + call readi(controlcard,"NREP",nrep,3) + call readi(controlcard,"NSTEX",nstex,1000) + call reada(controlcard,"RETMIN",retmin,10.0d0) + call reada(controlcard,"RETMAX",retmax,1000.0d0) + mremdsync=(index(controlcard,'SYNC').gt.0) + call readi(controlcard,"NSYN",i_sync_step,100) + restart1file=(index(controlcard,'REST1FILE').gt.0) + traj1file=(index(controlcard,'TRAJ1FILE').gt.0) + call readi(controlcard,"TRAJCACHE",max_cache_traj_use,1) + if(max_cache_traj_use.gt.max_cache_traj) & + max_cache_traj_use=max_cache_traj + if(me.eq.king.or..not.out1file) then +!d if (traj1file) then +!rc caching is in testing - NTWX is not ignored +!d write (iout,*) "NTWX value is ignored" +!d write (iout,*) " trajectory is stored to one file by master" +!d write (iout,*) " before exchange at NSTEX intervals" +!d endif + write (iout,*) "NREP= ",nrep + write (iout,*) "NSTEX= ",nstex + write (iout,*) "SYNC= ",mremdsync + write (iout,*) "NSYN= ",i_sync_step + write (iout,*) "TRAJCACHE= ",max_cache_traj_use + endif + remd_tlist=.false. + allocate(remd_t(nrep),remd_m(nrep)) !(maxprocs) + if (index(controlcard,'TLIST').gt.0) then + remd_tlist=.true. + call card_concat(controlcard1,.true.) + read(controlcard1,*) (remd_t(i),i=1,nrep) + if(me.eq.king.or..not.out1file) & + write (iout,*)'tlist',(remd_t(i),i=1,nrep) + endif + remd_mlist=.false. + if (index(controlcard,'MLIST').gt.0) then + remd_mlist=.true. + call card_concat(controlcard1,.true.) + read(controlcard1,*) (remd_m(i),i=1,nrep) + if(me.eq.king.or..not.out1file) then + write (iout,*)'mlist',(remd_m(i),i=1,nrep) + iremd_m_total=0 + do i=1,nrep + iremd_m_total=iremd_m_total+remd_m(i) + enddo + write (iout,*) 'Total number of replicas ',iremd_m_total + endif + endif + if(me.eq.king.or..not.out1file) & + write (iout,'(/30(1h=),a,29(1h=)/)') " End of REMD run setup " + return + end subroutine read_REMDpar +!----------------------------------------------------------------------------- + subroutine read_MDpar +! +! Read MD settings +! + use control_data, only: r_cut,rlamb,out1file + use energy_data + use geometry_data, only: pi + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.MD' + use MD_data +!el #ifndef LANG0 +!el include 'COMMON.LANGEVIN' +!el #else +!el include 'COMMON.LANGEVIN.lang0' +!el #endif +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.SETUP' +! include 'COMMON.CONTROL' +! include 'COMMON.SPLITELE' +! character(len=80) :: ucase + character(len=320) :: controlcard +!el local variables + integer :: i + real(kind=8) :: eta + + call card_concat(controlcard,.true.) + call readi(controlcard,"NSTEP",n_timestep,1000000) + call readi(controlcard,"NTWE",ntwe,100) + call readi(controlcard,"NTWX",ntwx,1000) + call reada(controlcard,"DT",d_time,1.0d-1) + call reada(controlcard,"DVMAX",dvmax,2.0d1) + call reada(controlcard,"DAMAX",damax,1.0d1) + call reada(controlcard,"EDRIFTMAX",edriftmax,1.0d+1) + call readi(controlcard,"LANG",lang,0) + RESPA = index(controlcard,"RESPA") .gt. 0 + call readi(controlcard,"NTIME_SPLIT",ntime_split,1) + ntime_split0=ntime_split + call readi(controlcard,"MAXTIME_SPLIT",maxtime_split,64) + ntime_split0=ntime_split + call reada(controlcard,"R_CUT",r_cut,2.0d0) + call reada(controlcard,"LAMBDA",rlamb,0.3d0) + rest = index(controlcard,"REST").gt.0 + tbf = index(controlcard,"TBF").gt.0 + usampl = index(controlcard,"USAMPL").gt.0 + mdpdb = index(controlcard,"MDPDB").gt.0 + call reada(controlcard,"T_BATH",t_bath,300.0d0) + call reada(controlcard,"TAU_BATH",tau_bath,1.0d-1) + call reada(controlcard,"EQ_TIME",eq_time,1.0d+4) + call readi(controlcard,"RESET_MOMENT",count_reset_moment,1000) + if (count_reset_moment.eq.0) count_reset_moment=1000000000 + call readi(controlcard,"RESET_VEL",count_reset_vel,1000) + reset_moment=lang.eq.0 .and. tbf .and. count_reset_moment.gt.0 + reset_vel=lang.eq.0 .and. tbf .and. count_reset_vel.gt.0 + if (count_reset_vel.eq.0) count_reset_vel=1000000000 + large = index(controlcard,"LARGE").gt.0 + print_compon = index(controlcard,"PRINT_COMPON").gt.0 + rattle = index(controlcard,"RATTLE").gt.0 +! if performing umbrella sampling, fragments constrained are read from the fragment file + nset=0 + if(usampl) then + call read_fragments + endif + + if(me.eq.king.or..not.out1file) then + write (iout,*) + write (iout,'(27(1h=),a26,27(1h=))') " Parameters of the MD run " + write (iout,*) + write (iout,'(a)') "The units are:" + write (iout,'(a)') "positions: angstrom, time: 48.9 fs" + write (iout,'(2a)') "velocity: angstrom/(48.9 fs),",& + " acceleration: angstrom/(48.9 fs)**2" + write (iout,'(a)') "energy: kcal/mol, temperature: K" + write (iout,*) + write (iout,'(a60,i10)') "Number of time steps:",n_timestep + write (iout,'(a60,f10.5,a)') & + "Initial time step of numerical integration:",d_time,& + " natural units" + write (iout,'(60x,f10.5,a)') d_time*48.9," fs" + if (RESPA) then + write (iout,'(2a,i4,a)') & + "A-MTS algorithm used; initial time step for fast-varying",& + " short-range forces split into",ntime_split," steps." + write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff",& + r_cut," lambda",rlamb + endif + write (iout,'(2a,f10.5)') & + "Maximum acceleration threshold to reduce the time step",& + "/increase split number:",damax + write (iout,'(2a,f10.5)') & + "Maximum predicted energy drift to reduce the timestep",& + "/increase split number:",edriftmax + write (iout,'(a60,f10.5)') & + "Maximum velocity threshold to reduce velocities:",dvmax + write (iout,'(a60,i10)') "Frequency of property output:",ntwe + write (iout,'(a60,i10)') "Frequency of coordinate output:",ntwx + if (rattle) write (iout,'(a60)') & + "Rattle algorithm used to constrain the virtual bonds" + endif + reset_fricmat=1000 + if (lang.gt.0) then + call reada(controlcard,"ETAWAT",etawat,0.8904d0) + call reada(controlcard,"RWAT",rwat,1.4d0) + call reada(controlcard,"SCAL_FRIC",scal_fric,2.0d-2) + surfarea=index(controlcard,"SURFAREA").gt.0 + call readi(controlcard,"RESET_FRICMAT",reset_fricmat,1000) + if(me.eq.king.or..not.out1file)then + write (iout,'(/a,$)') "Langevin dynamics calculation" + if (lang.eq.1) then + write (iout,'(a/)') & + " with direct integration of Langevin equations" + else if (lang.eq.2) then + write (iout,'(a/)') " with TINKER stochasic MD integrator" + else if (lang.eq.3) then + write (iout,'(a/)') " with Ciccotti's stochasic MD integrator" + else if (lang.eq.4) then + write (iout,'(a/)') " in overdamped mode" + else + write (iout,'(//a,i5)') & + "=========== ERROR: Unknown Langevin dynamics mode:",lang + stop + endif + write (iout,'(a60,f10.5)') "Temperature:",t_bath + write (iout,'(a60,f10.5)') "Viscosity of the solvent:",etawat + write (iout,'(a60,f10.5)') "Radius of solvent molecule:",rwat + write (iout,'(a60,f10.5)') & + "Scaling factor of the friction forces:",scal_fric + if (surfarea) write (iout,'(2a,i10,a)') & + "Friction coefficients will be scaled by solvent-accessible",& + " surface area every",reset_fricmat," steps." + endif +! Calculate friction coefficients and bounds of stochastic forces + eta=6*pi*cPoise*etawat + if(me.eq.king.or..not.out1file) & + write(iout,'(a60,f10.5)')"Eta of the solvent in natural units:",& + eta + gamp=scal_fric*(pstok+rwat)*eta + stdfp=dsqrt(2*Rb*t_bath/d_time) + allocate(gamsc(ntyp1),stdfsc(ntyp1)) !(ntyp1) + do i=1,ntyp + gamsc(i)=scal_fric*(restok(i)+rwat)*eta + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + if(me.eq.king.or..not.out1file)then + write (iout,'(/2a/)') & + "Radii of site types and friction coefficients and std's of",& + " stochastic forces of fully exposed sites" + write (iout,'(a5,f5.2,2f10.5)')'p',pstok,gamp,stdfp*dsqrt(gamp) + do i=1,ntyp + write (iout,'(a5,f5.2,2f10.5)') restyp(i),restok(i),& + gamsc(i),stdfsc(i)*dsqrt(gamsc(i)) + enddo + endif + else if (tbf) then + if(me.eq.king.or..not.out1file)then + write (iout,'(a)') "Berendsen bath calculation" + write (iout,'(a60,f10.5)') "Temperature:",t_bath + write (iout,'(a60,f10.5)') "Coupling constant (tau):",tau_bath + if (reset_moment) & + write (iout,'(a,i10,a)') "Momenta will be reset at zero every",& + count_reset_moment," steps" + if (reset_vel) & + write (iout,'(a,i10,a)') & + "Velocities will be reset at random every",count_reset_vel,& + " steps" + endif + else + if(me.eq.king.or..not.out1file) & + write (iout,'(a31)') "Microcanonical mode calculation" + endif + if(me.eq.king.or..not.out1file)then + if (rest) write (iout,'(/a/)') "===== Calculation restarted ====" + if (usampl) then + write(iout,*) "MD running with constraints." + write(iout,*) "Equilibration time ", eq_time, " mtus." + write(iout,*) "Constraining ", nfrag," fragments." + write(iout,*) "Length of each fragment, weight and q0:" + do iset=1,nset + write (iout,*) "Set of restraints #",iset + do i=1,nfrag + write(iout,'(2i5,f8.1,f7.4)') ifrag(1,i,iset),& + ifrag(2,i,iset),wfrag(i,iset),qinfrag(i,iset) + enddo + write(iout,*) "constraints between ", npair, "fragments." + write(iout,*) "constraint pairs, weights and q0:" + do i=1,npair + write(iout,'(2i5,f8.1,f7.4)') ipair(1,i,iset),& + ipair(2,i,iset),wpair(i,iset),qinpair(i,iset) + enddo + write(iout,*) "angle constraints within ", nfrag_back,& + "backbone fragments." + write(iout,*) "fragment, weights:" + do i=1,nfrag_back + write(iout,'(2i5,3f8.1)') ifrag_back(1,i,iset),& + ifrag_back(2,i,iset),wfrag_back(1,i,iset),& + wfrag_back(2,i,iset),wfrag_back(3,i,iset) + enddo + enddo + iset=mod(kolor,nset)+1 + endif + endif + if(me.eq.king.or..not.out1file) & + write (iout,'(/30(1h=),a,29(1h=)/)') " End of MD run setup " + return + end subroutine read_MDpar +!----------------------------------------------------------------------------- + subroutine map_read + + use map_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MAP' +! include 'COMMON.IOUNITS' + character(len=3) :: angid(4) = (/'THE','PHI','ALP','OME'/) + character(len=80) :: mapcard !,ucase +!el local variables + integer :: imap +! real(kind=8) :: var,ene + + do imap=1,nmap + read (inp,'(a)') mapcard + mapcard=ucase(mapcard) + if (index(mapcard,'PHI').gt.0) then + kang(imap)=1 + else if (index(mapcard,'THE').gt.0) then + kang(imap)=2 + else if (index(mapcard,'ALP').gt.0) then + kang(imap)=3 + else if (index(mapcard,'OME').gt.0) then + kang(imap)=4 + else + write(iout,'(a)')'Error - illegal variable spec in MAP card.' + stop 'Error - illegal variable spec in MAP card.' + endif + call readi (mapcard,'RES1',res1(imap),0) + call readi (mapcard,'RES2',res2(imap),0) + if (res1(imap).eq.0) then + res1(imap)=res2(imap) + else if (res2(imap).eq.0) then + res2(imap)=res1(imap) + endif + if(res1(imap)*res2(imap).eq.0 .or. res1(imap).gt.res2(imap))then + write (iout,'(a)') & + 'Error - illegal definition of variable group in MAP.' + stop 'Error - illegal definition of variable group in MAP.' + endif + call reada(mapcard,'FROM',ang_from(imap),0.0D0) + call reada(mapcard,'TO',ang_to(imap),0.0D0) + call readi(mapcard,'NSTEP',nstep(imap),0) + if (ang_from(imap).eq.ang_to(imap) .or. nstep(imap).eq.0) then + write (iout,'(a)') & + 'Illegal boundary and/or step size specification in MAP.' + stop 'Illegal boundary and/or step size specification in MAP.' + endif + enddo ! imap + return + end subroutine map_read +!----------------------------------------------------------------------------- + subroutine csaread + + use control_data, only: vdisulf + use csa_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.CONTROL' +! character(len=80) :: ucase + character(len=620) :: mcmcard +!el local variables +! integer :: ntf,ik,iw_pdb +! real(kind=8) :: var,ene + + call card_concat(mcmcard,.true.) + + call readi(mcmcard,'NCONF',nconf,50) + call readi(mcmcard,'NADD',nadd,0) + call readi(mcmcard,'JSTART',jstart,1) + call readi(mcmcard,'JEND',jend,1) + call readi(mcmcard,'NSTMAX',nstmax,500000) + call readi(mcmcard,'N0',n0,1) + call readi(mcmcard,'N1',n1,6) + call readi(mcmcard,'N2',n2,4) + call readi(mcmcard,'N3',n3,0) + call readi(mcmcard,'N4',n4,0) + call readi(mcmcard,'N5',n5,0) + call readi(mcmcard,'N6',n6,10) + call readi(mcmcard,'N7',n7,0) + call readi(mcmcard,'N8',n8,0) + call readi(mcmcard,'N9',n9,0) + call readi(mcmcard,'N14',n14,0) + call readi(mcmcard,'N15',n15,0) + call readi(mcmcard,'N16',n16,0) + call readi(mcmcard,'N17',n17,0) + call readi(mcmcard,'N18',n18,0) + + vdisulf=(index(mcmcard,'DYNSS').gt.0) + + call readi(mcmcard,'NDIFF',ndiff,2) + call reada(mcmcard,'DIFFCUT',diffcut,0.0d0) + call readi(mcmcard,'IS1',is1,1) + call readi(mcmcard,'IS2',is2,8) + call readi(mcmcard,'NRAN0',nran0,4) + call readi(mcmcard,'NRAN1',nran1,2) + call readi(mcmcard,'IRR',irr,1) + call readi(mcmcard,'NSEED',nseed,20) + call readi(mcmcard,'NTOTAL',ntotal,10000) + call reada(mcmcard,'CUT1',cut1,2.0d0) + call reada(mcmcard,'CUT2',cut2,5.0d0) + call reada(mcmcard,'ESTOP',estop,-3000.0d0) + call readi(mcmcard,'ICMAX',icmax,3) + call readi(mcmcard,'IRESTART',irestart,0) +!!bankt call readi(mcmcard,'NBANKTM',ntbankm,0) + ntbankm=0 +!!bankt + call reada(mcmcard,'DELE',dele,20.0d0) + call reada(mcmcard,'DIFCUT',difcut,720.0d0) + call readi(mcmcard,'IREF',iref,0) + call reada(mcmcard,'RMSCUT',rmscut,4.0d0) + call reada(mcmcard,'PNCCUT',pnccut,0.5d0) + call readi(mcmcard,'NCONF_IN',nconf_in,0) + call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) + write (iout,*) "NCONF_IN",nconf_in + return + end subroutine csaread +!----------------------------------------------------------------------------- + subroutine mcmread + + use mcm_data + use control_data, only: MaxMoveType + use MD_data + use minim_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MCM' +! include 'COMMON.MCE' +! include 'COMMON.IOUNITS' +! character(len=80) :: ucase + character(len=320) :: mcmcard +!el local variables + integer :: i +! real(kind=8) :: var,ene + + call card_concat(mcmcard,.true.) + call readi(mcmcard,'MAXACC',maxacc,100) + call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000) + call readi(mcmcard,'MAXTRIAL',maxtrial,100) + call readi(mcmcard,'MAXTRIAL_ITER',maxtrial_iter,1000) + call readi(mcmcard,'MAXREPM',maxrepm,200) + call reada(mcmcard,'RANFRACT',RanFract,0.5D0) + call reada(mcmcard,'POOL_FRACT',pool_fraction,0.01D0) + call reada(mcmcard,'OVERLAP',overlap_cut,1.0D3) + call reada(mcmcard,'E_UP',e_up,5.0D0) + call reada(mcmcard,'DELTE',delte,0.1D0) + call readi(mcmcard,'NSWEEP',nsweep,5) + call readi(mcmcard,'NSTEPH',nsteph,0) + call readi(mcmcard,'NSTEPC',nstepc,0) + call reada(mcmcard,'TMIN',tmin,298.0D0) + call reada(mcmcard,'TMAX',tmax,298.0D0) + call readi(mcmcard,'NWINDOW',nwindow,0) + call readi(mcmcard,'PRINT_MC',print_mc,0) + print_stat=(index(mcmcard,'NO_PRINT_STAT').le.0) + print_int=(index(mcmcard,'NO_PRINT_INT').le.0) + ent_read=(index(mcmcard,'ENT_READ').gt.0) + call readi(mcmcard,'SAVE_FREQ',save_frequency,1000) + call readi(mcmcard,'MESSAGE_FREQ',message_frequency,1000) + call readi(mcmcard,'POOL_READ_FREQ',pool_read_freq,5000) + call readi(mcmcard,'POOL_SAVE_FREQ',pool_save_freq,1000) + call readi(mcmcard,'PRINT_FREQ',print_freq,1000) + if (nwindow.gt.0) then + allocate(winstart(nwindow)) !!el (maxres) + allocate(winend(nwindow)) !!el + allocate(winlen(nwindow)) !!el + read (inp,*) (winstart(i),winend(i),i=1,nwindow) + do i=1,nwindow + winlen(i)=winend(i)-winstart(i)+1 + enddo + endif + if (tmax.lt.tmin) tmax=tmin + if (tmax.eq.tmin) then + nstepc=0 + nsteph=0 + endif + if (nstepc.gt.0 .and. nsteph.gt.0) then + tsteph=(tmax/tmin)**(1.0D0/(nsteph+0.0D0)) + tstepc=(tmax/tmin)**(1.0D0/(nstepc+0.0D0)) + endif + allocate(sumpro_type(0:MaxMoveType)) !(0:MaxMoveType) +! Probabilities of different move types + sumpro_type(0)=0.0D0 + call reada(mcmcard,'MULTI_BOND',sumpro_type(1),1.0d0) + call reada(mcmcard,'ONE_ANGLE' ,sumpro_type(2),2.0d0) + sumpro_type(2)=sumpro_type(1)+sumpro_type(2) + call reada(mcmcard,'THETA' ,sumpro_type(3),0.0d0) + sumpro_type(3)=sumpro_type(2)+sumpro_type(3) + call reada(mcmcard,'SIDE_CHAIN',sumpro_type(4),0.5d0) + sumpro_type(4)=sumpro_type(3)+sumpro_type(4) + do i=1,MaxMoveType + print *,'i',i,' sumprotype',sumpro_type(i) + sumpro_type(i)=sumpro_type(i)/sumpro_type(MaxMoveType) + print *,'i',i,' sumprotype',sumpro_type(i) + enddo + return + end subroutine mcmread +!----------------------------------------------------------------------------- + subroutine read_minim + + use minim_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MINIM' +! include 'COMMON.IOUNITS' +! character(len=80) :: ucase + character(len=320) :: minimcard +!el local variables +! integer :: ntf,ik,iw_pdb +! real(kind=8) :: var,ene + + call card_concat(minimcard,.true.) + call readi(minimcard,'MAXMIN',maxmin,2000) + call readi(minimcard,'MAXFUN',maxfun,5000) + call readi(minimcard,'MINMIN',minmin,maxmin) + call readi(minimcard,'MINFUN',minfun,maxmin) + call reada(minimcard,'TOLF',tolf,1.0D-2) + call reada(minimcard,'RTOLF',rtolf,1.0D-4) + print_min_stat=min0(index(minimcard,'PRINT_MIN_STAT'),1) + print_min_res=min0(index(minimcard,'PRINT_MIN_RES'),1) + print_min_ini=min0(index(minimcard,'PRINT_MIN_INI'),1) + write (iout,'(/80(1h*)/20x,a/80(1h*))') & + 'Options in energy minimization:' + write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)') & + 'MaxMin:',MaxMin,' MaxFun:',MaxFun,& + 'MinMin:',MinMin,' MinFun:',MinFun,& + ' TolF:',TolF,' RTolF:',RTolF + return + end subroutine read_minim +!----------------------------------------------------------------------------- + subroutine openunits + + use energy_data, only: usampl + use csa_data + use MPI_data + use control_data, only:out1file + use control, only: getenv_loc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + character(len=16) :: form,nodename + integer :: nodelen,ierror,npos +#endif +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' +! include 'COMMON.MD' +! include 'COMMON.CONTROL' + integer :: lenpre,lenpot,lentmp !,ilen +!el external ilen + character(len=3) :: out1file_text !,ucase + character(len=3) :: ll +!el external ucase +!el local variables +! integer :: ntf,ik,iw_pdb +! real(kind=8) :: var,ene +! +! print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits" + call getenv_loc("PREFIX",prefix) + pref_orig = prefix + call getenv_loc("POT",pot) + call getenv_loc("DIRTMP",tmpdir) + call getenv_loc("CURDIR",curdir) + call getenv_loc("OUT1FILE",out1file_text) +! print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV" + out1file_text=ucase(out1file_text) + if (out1file_text(1:1).eq."Y") then + out1file=.true. + else + out1file=fg_rank.gt.0 + endif + lenpre=ilen(prefix) + lenpot=ilen(pot) + lentmp=ilen(tmpdir) + if (lentmp.gt.0) then + write (*,'(80(1h!))') + write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!" + write (*,'(80(1h!))') + write (*,*)"All output files will be on node /tmp directory." +#ifdef MPI + call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR ) + if (me.eq.king) then + write (*,*) "The master node is ",nodename + else if (fg_rank.eq.0) then + write (*,*) "I am the CG slave node ",nodename + else + write (*,*) "I am the FG slave node ",nodename + endif +#endif + PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre) + lenpre = lentmp+lenpre+1 + endif + entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' +! Get the names and open the input files +#if defined(WINIFL) || defined(WINPGI) + open(1,file=pref_orig(:ilen(pref_orig))// & + '.inp',status='old',readonly,shared) + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +! Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old',readonly,shared) + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',readonly,shared) + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',readonly,shared) + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',readonly,shared) + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',readonly,shared) + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',readonly,shared) + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',readonly,shared) + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old',& + action='read') +! print *,"Processor",myrank," opened file 1" + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +! print *,"Processor",myrank," opened file 9" +! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +! Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old',action='read') +! print *,"Processor",myrank," opened file IBOND" + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',action='read') +! print *,"Processor",myrank," opened file ITHEP" + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',action='read') +! print *,"Processor",myrank," opened file IROTAM" + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',action='read') +! print *,"Processor",myrank," opened file ITORP" + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',action='read') +! print *,"Processor",myrank," opened file ITORDP" + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old',action='read') +! print *,"Processor",myrank," opened file ISCCOR" + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',action='read') +! print *,"Processor",myrank," opened file IFOURIER" + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',action='read') +! print *,"Processor",myrank," opened file IELEP" + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',action='read') +! print *,"Processor",myrank," opened file ISIDEP" +! print *,"Processor",myrank," opened parameter files" +#elif (defined G77) + open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old') + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +! Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old') + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old') + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old') + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old') + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old') + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old') + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old') + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old') + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old') +#else + open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old',& + readonly) + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +! Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old',action='read') + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',action='read') + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',action='read') + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',action='read') + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',action='read') + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old',action='read') +#ifndef CRYST_THETA + call getenv_loc('THETPARPDB',thetname_pdb) + print *,"thetname_pdb ",thetname_pdb + open (ithep_pdb,file=thetname_pdb,status='old',action='read') + print *,ithep_pdb," opened" +#endif + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',readonly) + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',readonly) + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',readonly) +#ifndef CRYST_SC + call getenv_loc('ROTPARPDB',rotname_pdb) + open (irotam_pdb,file=rotname_pdb,status='old',action='read') +#endif +#endif +#ifndef OLDSCP +! +! 8/9/01 In the newest version SCp interaction constants are read from a file +! Use -DOLDSCP to use hard-coded constants instead. +! + call getenv_loc('SCPPAR',scpname) +#if defined(WINIFL) || defined(WINPGI) + open (iscpp,file=scpname,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open (iscpp,file=scpname,status='old',action='read') +#elif (defined G77) + open (iscpp,file=scpname,status='old') +#else + open (iscpp,file=scpname,status='old',action='read') +#endif +#endif + call getenv_loc('PATTERN',patname) +#if defined(WINIFL) || defined(WINPGI) + open (icbase,file=patname,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open (icbase,file=patname,status='old',action='read') +#elif (defined G77) + open (icbase,file=patname,status='old') +#else + open (icbase,file=patname,status='old',action='read') +#endif +#ifdef MPI +! Open output file only for CG processes +! print *,"Processor",myrank," fg_rank",fg_rank + if (fg_rank.eq.0) then + + if (nodes.eq.1) then + npos=3 + else + npos = dlog10(dfloat(nodes-1))+1 + endif + if (npos.lt.3) npos=3 + write (liczba,'(i1)') npos + form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba)) & + //')' + write (liczba,form) me + outname=prefix(:lenpre)//'.out_'//pot(:lenpot)// & + liczba(:ilen(liczba)) + intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) & + //'.int' + pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) & + //'.pdb' + mol2name=prefix(:lenpre)//'_'//pot(:lenpot)// & + liczba(:ilen(liczba))//'.mol2' + statname=prefix(:lenpre)//'_'//pot(:lenpot)// & + liczba(:ilen(liczba))//'.stat' + if (lentmp.gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) & + //liczba(:ilen(liczba))//'.stat') + rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba)) & + //'.rst' + if(usampl) then + qname=prefix(:lenpre)//'_'//pot(:lenpot)// & + liczba(:ilen(liczba))//'.const' + endif + + endif +#else + outname=prefix(:lenpre)//'.out_'//pot(:lenpot) + intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int' + pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb' + mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2' + statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat' + if (lentmp.gt.0) & + call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot)// & + '.stat') + rest2name=prefix(:ilen(prefix))//'.rst' + if(usampl) then + qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' + endif +#endif +#if defined(AIX) || defined(PGI) + if (me.eq.king .or. .not. out1file) & + open(iout,file=outname,status='unknown') +#ifdef DEBUG + if (fg_rank.gt.0) then + write (liczba,'(i3.3)') myrank/nfgtasks + write (ll,'(bz,i3.3)') fg_rank + open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll,& + status='unknown') + endif +#endif + if(me.eq.king) then + open(igeom,file=intname,status='unknown',position='append') + open(ipdb,file=pdbname,status='unknown') + open(imol2,file=mol2name,status='unknown') + open(istat,file=statname,status='unknown',position='append') + else +!1out open(iout,file=outname,status='unknown') + endif +#else + if (me.eq.king .or. .not.out1file) & + open(iout,file=outname,status='unknown') +#ifdef DEBUG + if (fg_rank.gt.0) then + write (liczba,'(i3.3)') myrank/nfgtasks + write (ll,'(bz,i3.3)') fg_rank + open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll,& + status='unknown') + endif +#endif + if(me.eq.king) then + open(igeom,file=intname,status='unknown',access='append') + open(ipdb,file=pdbname,status='unknown') + open(imol2,file=mol2name,status='unknown') + open(istat,file=statname,status='unknown',access='append') + else +!1out open(iout,file=outname,status='unknown') + endif +#endif + csa_rbank=prefix(:lenpre)//'.CSA.rbank' + csa_seed=prefix(:lenpre)//'.CSA.seed' + csa_history=prefix(:lenpre)//'.CSA.history' + csa_bank=prefix(:lenpre)//'.CSA.bank' + csa_bank1=prefix(:lenpre)//'.CSA.bank1' + csa_alpha=prefix(:lenpre)//'.CSA.alpha' + csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' +!!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' + csa_int=prefix(:lenpre)//'.int' + csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' + csa_native_int=prefix(:lenpre)//'.CSA.native.int' + csa_in=prefix(:lenpre)//'.CSA.in' +! print *,"Processor",myrank,"fg_rank",fg_rank," opened files" +! Write file names + if (me.eq.king)then + write (iout,'(80(1h-))') + write (iout,'(30x,a)') "FILE ASSIGNMENT" + write (iout,'(80(1h-))') + write (iout,*) "Input file : ",& + pref_orig(:ilen(pref_orig))//'.inp' + write (iout,*) "Output file : ",& + outname(:ilen(outname)) + write (iout,*) + write (iout,*) "Sidechain potential file : ",& + sidename(:ilen(sidename)) +#ifndef OLDSCP + write (iout,*) "SCp potential file : ",& + scpname(:ilen(scpname)) +#endif + write (iout,*) "Electrostatic potential file : ",& + elename(:ilen(elename)) + write (iout,*) "Cumulant coefficient file : ",& + fouriername(:ilen(fouriername)) + write (iout,*) "Torsional parameter file : ",& + torname(:ilen(torname)) + write (iout,*) "Double torsional parameter file : ",& + tordname(:ilen(tordname)) + write (iout,*) "SCCOR parameter file : ",& + sccorname(:ilen(sccorname)) + write (iout,*) "Bond & inertia constant file : ",& + bondname(:ilen(bondname)) + write (iout,*) "Bending parameter file : ",& + thetname(:ilen(thetname)) + write (iout,*) "Rotamer parameter file : ",& + rotname(:ilen(rotname)) +!el---- +#ifndef CRYST_THETA + write (iout,*) "Thetpdb parameter file : ",& + thetname_pdb(:ilen(thetname_pdb)) +#endif +!el + write (iout,*) "Threading database : ",& + patname(:ilen(patname)) + if (lentmp.ne.0) & + write (iout,*)" DIRTMP : ",& + tmpdir(:lentmp) + write (iout,'(80(1h-))') + endif + return + end subroutine openunits +!----------------------------------------------------------------------------- + subroutine readrst + + use geometry_data, only: nres,dc + use energy_data, only: usampl,iset + use MD_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.MD' +!el local variables + integer ::i,j +! real(kind=8) :: var,ene + + open(irest2,file=rest2name,status='unknown') + read(irest2,*) totT,EK,potE,totE,t_bath + do i=1,2*nres + read(irest2,'(3e15.5)') (d_t(j,i),j=1,3) + enddo + do i=1,2*nres + read(irest2,'(3e15.5)') (dc(j,i),j=1,3) + enddo + if(usampl) then + read (irest2,*) iset + endif + close(irest2) + return + end subroutine readrst +!----------------------------------------------------------------------------- + subroutine read_fragments + + use energy_data +! use geometry + use control_data, only:out1file + use MD_data + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.MD' +! include 'COMMON.CONTROL' +!el local variables + integer :: i +! real(kind=8) :: var,ene + + read(inp,*) nset,nfrag,npair,nfrag_back + +!el from module energy +! if(.not.allocated(mset)) allocate(mset(nset)) !(maxprocs/20) + if(.not.allocated(wfrag_back)) then + allocate(wfrag_back(3,nfrag_back,nset)) !(3,maxfrag_back,maxprocs/20) + allocate(ifrag_back(3,nfrag_back,nset)) !(3,maxfrag_back,maxprocs/20) + + allocate(qinfrag(nfrag,nset),wfrag(nfrag,nset)) !(50,maxprocs/20) + allocate(ifrag(2,nfrag,nset)) !(2,50,maxprocs/20) + + allocate(qinpair(npair,nset),wpair(npair,nset)) !(100,maxprocs/20) + allocate(ipair(2,npair,nset)) !(2,100,maxprocs/20) + endif + + if(me.eq.king.or..not.out1file) & + write(iout,*) "nset",nset," nfrag",nfrag," npair",npair,& + " nfrag_back",nfrag_back + do iset=1,nset + read(inp,*) mset(iset) + do i=1,nfrag + read(inp,*) wfrag(i,iset),ifrag(1,i,iset),ifrag(2,i,iset),& + qinfrag(i,iset) + if(me.eq.king.or..not.out1file) & + write(iout,*) "R ",i,wfrag(i,iset),ifrag(1,i,iset),& + ifrag(2,i,iset), qinfrag(i,iset) + enddo + do i=1,npair + read(inp,*) wpair(i,iset),ipair(1,i,iset),ipair(2,i,iset),& + qinpair(i,iset) + if(me.eq.king.or..not.out1file) & + write(iout,*) "R ",i,wpair(i,iset),ipair(1,i,iset),& + ipair(2,i,iset), qinpair(i,iset) + enddo + do i=1,nfrag_back + read(inp,*) wfrag_back(1,i,iset),wfrag_back(2,i,iset),& + wfrag_back(3,i,iset),& + ifrag_back(1,i,iset),ifrag_back(2,i,iset) + if(me.eq.king.or..not.out1file) & + write(iout,*) "A",i,wfrag_back(1,i,iset),wfrag_back(2,i,iset),& + wfrag_back(3,i,iset),ifrag_back(1,i,iset),ifrag_back(2,i,iset) + enddo + enddo + return + end subroutine read_fragments +!----------------------------------------------------------------------------- +! shift.F io_csa +!----------------------------------------------------------------------------- + subroutine csa_read + + use csa_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.IOUNITS' +!el local variables +! integer :: ntf,ik,iw_pdb +! real(kind=8) :: var,ene + + open(icsa_in,file=csa_in,status="old",err=100) + read(icsa_in,*) nconf + read(icsa_in,*) jstart,jend + read(icsa_in,*) nstmax + read(icsa_in,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 + read(icsa_in,*) nran0,nran1,irr + read(icsa_in,*) nseed + read(icsa_in,*) ntotal,cut1,cut2 + read(icsa_in,*) estop + read(icsa_in,*) icmax,irestart + read(icsa_in,*) ntbankm,dele,difcut + read(icsa_in,*) iref,rmscut,pnccut + read(icsa_in,*) ndiff + close(icsa_in) + + return + + 100 continue + return + end subroutine csa_read +!----------------------------------------------------------------------------- + subroutine initial_write + + use csa_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +! include 'COMMON.IOUNITS' +!el local variables +! integer :: ntf,ik,iw_pdb +! real(kind=8) :: var,ene + + open(icsa_seed,file=csa_seed,status="unknown") + write(icsa_seed,*) "seed" + close(31) +#if defined(AIX) || defined(PGI) + open(icsa_history,file=csa_history,status="unknown",& + position="append") +#else + open(icsa_history,file=csa_history,status="unknown",& + access="append") +#endif + write(icsa_history,*) nconf + write(icsa_history,*) jstart,jend + write(icsa_history,*) nstmax + write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 + write(icsa_history,*) nran0,nran1,irr + write(icsa_history,*) nseed + write(icsa_history,*) ntotal,cut1,cut2 + write(icsa_history,*) estop + write(icsa_history,*) icmax,irestart + write(icsa_history,*) ntbankm,dele,difcut + write(icsa_history,*) iref,rmscut,pnccut + write(icsa_history,*) ndiff + + write(icsa_history,*) + close(icsa_history) + + open(icsa_bank1,file=csa_bank1,status="unknown") + write(icsa_bank1,*) 0 + close(icsa_bank1) + + return + end subroutine initial_write +!----------------------------------------------------------------------------- + subroutine restart_write + + use csa_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CSA' +! include 'COMMON.BANK' +!el local variables +! integer :: ntf,ik,iw_pdb +! real(kind=8) :: var,ene + +#if defined(AIX) || defined(PGI) + open(icsa_history,file=csa_history,position="append") +#else + open(icsa_history,file=csa_history,access="append") +#endif + write(icsa_history,*) + write(icsa_history,*) "This is restart" + write(icsa_history,*) + write(icsa_history,*) nconf + write(icsa_history,*) jstart,jend + write(icsa_history,*) nstmax + write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 + write(icsa_history,*) nran0,nran1,irr + write(icsa_history,*) nseed + write(icsa_history,*) ntotal,cut1,cut2 + write(icsa_history,*) estop + write(icsa_history,*) icmax,irestart + write(icsa_history,*) ntbankm,dele,difcut + write(icsa_history,*) iref,rmscut,pnccut + write(icsa_history,*) ndiff + write(icsa_history,*) + write(icsa_history,*) "irestart is: ", irestart + + write(icsa_history,*) + close(icsa_history) + + return + end subroutine restart_write +!----------------------------------------------------------------------------- +! test.F +!----------------------------------------------------------------------------- + subroutine write_pdb(npdb,titelloc,ee) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + character(len=50) :: titelloc1 + character*(*) :: titelloc + character(len=3) :: zahl + character(len=5) :: liczba5 + real(kind=8) :: ee + integer :: npdb !,ilen +!el external ilen +!el local variables + integer :: lenpre +! real(kind=8) :: var,ene + + titelloc1=titelloc + lenpre=ilen(prefix) + if (npdb.lt.1000) then + call numstr(npdb,zahl) + open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') + else + if (npdb.lt.10000) then + write(liczba5,'(i1,i4)') 0,npdb + else + write(liczba5,'(i5)') npdb + endif + open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') + endif + call pdbout(ee,titelloc1,ipdb) + close(ipdb) + return + end subroutine write_pdb +!----------------------------------------------------------------------------- +! thread.F +!----------------------------------------------------------------------------- + subroutine write_thread_summary +! Thread the sequence through a database of known structures + use control_data, only: refstr +! use geometry + use energy_data, only: n_ene_comp + use compare_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + use MPI_data !include 'COMMON.INFO' + include 'mpif.h' +#endif +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.DBASE' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.THREAD' +! include 'COMMON.FFIELD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.HEADER' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' + + integer,dimension(maxthread) :: ip + real(kind=8),dimension(0:n_ene) :: energia +!el local variables + integer :: i,j,ii,jj,ipj,ik,kk,ist + real(kind=8) :: enet,etot,rmsnat,rms,frac,frac_nn + + write (iout,'(30x,a/)') & + ' *********** Summary threading statistics ************' + write (iout,'(a)') 'Initial energies:' + write (iout,'(a4,2x,a12,14a14,3a8)') & + 'No','seq',(ename(print_order(i)),i=1,nprint_ene),'ETOT',& + 'RMSnat','NatCONT','NNCONT','RMS' +! Energy sort patterns + do i=1,nthread + ip(i)=i + enddo + do i=1,nthread-1 + enet=ener(n_ene-1,ip(i)) + jj=i + do j=i+1,nthread + if (ener(n_ene-1,ip(j)).lt.enet) then + jj=j + enet=ener(n_ene-1,ip(j)) + endif + enddo + if (jj.ne.i) then + ipj=ip(jj) + ip(jj)=ip(i) + ip(i)=ipj + endif + enddo + do ik=1,nthread + i=ip(ik) + ii=ipatt(1,i) + ist=nres_base(2,ii)+ipatt(2,i) + do kk=1,n_ene_comp + energia(i)=ener0(kk,i) + enddo + etot=ener0(n_ene_comp+1,i) + rmsnat=ener0(n_ene_comp+2,i) + rms=ener0(n_ene_comp+3,i) + frac=ener0(n_ene_comp+4,i) + frac_nn=ener0(n_ene_comp+5,i) + + if (refstr) then + write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') & + i,str_nam(ii),ist+1,& + (energia(print_order(kk)),kk=1,nprint_ene),& + etot,rmsnat,frac,frac_nn,rms + else + write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3)') & + i,str_nam(ii),ist+1,& + (energia(print_order(kk)),kk=1,nprint_ene),etot + endif + enddo + write (iout,'(//a)') 'Final energies:' + write (iout,'(a4,2x,a12,17a14,3a8)') & + 'No','seq',(ename(print_order(kk)),kk=1,nprint_ene),'ETOT',& + 'RMSnat','NatCONT','NNCONT','RMS' + do ik=1,nthread + i=ip(ik) + ii=ipatt(1,i) + ist=nres_base(2,ii)+ipatt(2,i) + do kk=1,n_ene_comp + energia(kk)=ener(kk,ik) + enddo + etot=ener(n_ene_comp+1,i) + rmsnat=ener(n_ene_comp+2,i) + rms=ener(n_ene_comp+3,i) + frac=ener(n_ene_comp+4,i) + frac_nn=ener(n_ene_comp+5,i) + write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') & + i,str_nam(ii),ist+1,& + (energia(print_order(kk)),kk=1,nprint_ene),& + etot,rmsnat,frac,frac_nn,rms + enddo + write (iout,'(/a/)') 'IEXAM array:' + write (iout,'(i5)') nexcl + do i=1,nexcl + write (iout,'(2i5)') iexam(1,i),iexam(2,i) + enddo + write (iout,'(/a,1pe14.4/a,1pe14.4/)') & + 'Max. time for threading step ',max_time_for_thread,& + 'Average time for threading step: ',ave_time_for_thread + return + end subroutine write_thread_summary +!----------------------------------------------------------------------------- + subroutine write_stat_thread(ithread,ipattern,ist) + + use energy_data, only: n_ene_comp + use compare_data +! implicit real*8 (a-h,o-z) +! include "DIMENSIONS" +! include "COMMON.CONTROL" +! include "COMMON.IOUNITS" +! include "COMMON.THREAD" +! include "COMMON.FFIELD" +! include "COMMON.DBASE" +! include "COMMON.NAMES" + real(kind=8),dimension(0:n_ene) :: energia +!el local variables + integer :: ithread,ipattern,ist,i + real(kind=8) :: etot,rmsnat,rms,frac,frac_nn + +#if defined(AIX) || defined(PGI) + open(istat,file=statname,position='append') +#else + open(istat,file=statname,access='append') +#endif + do i=1,n_ene_comp + energia(i)=ener(i,ithread) + enddo + etot=ener(n_ene_comp+1,ithread) + rmsnat=ener(n_ene_comp+2,ithread) + rms=ener(n_ene_comp+3,ithread) + frac=ener(n_ene_comp+4,ithread) + frac_nn=ener(n_ene_comp+5,ithread) + write (istat,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') & + ithread,str_nam(ipattern),ist+1,& + (energia(print_order(i)),i=1,nprint_ene),& + etot,rmsnat,frac,frac_nn,rms + close (istat) + return + end subroutine write_stat_thread +!----------------------------------------------------------------------------- +#endif +!----------------------------------------------------------------------------- + end module io_config diff --git a/source/unres/io_config.f90 b/source/unres/io_config.f90 deleted file mode 100644 index aedb3dd..0000000 --- a/source/unres/io_config.f90 +++ /dev/null @@ -1,4252 +0,0 @@ - module io_config - - use names - use io_units - use io_base - use geometry_data - use geometry - use control_data, only:maxterm_sccor - implicit none -!----------------------------------------------------------------------------- -! Max. number of residue types and parameters in expressions for -! virtual-bond angle bending potentials -! integer,parameter :: maxthetyp=3 -! integer,parameter :: maxthetyp1=maxthetyp+1 -! ,maxtheterm=20, -! & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, -! & mmaxtheterm=maxtheterm) -!----------------------------------------------------------------------------- -! Max. number of types of dihedral angles & multiplicity of torsional barriers -! and the number of terms in double torsionals -! integer,parameter :: maxlor=3,maxtermd_1=8,maxtermd_2=8 -! parameter (maxtor=4,maxterm=10) -!----------------------------------------------------------------------------- -! Max number of torsional terms in SCCOR -!el integer,parameter :: maxterm_sccor=6 -!----------------------------------------------------------------------------- - character(len=1),dimension(:),allocatable :: secstruc !(maxres) -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- -! bank.F io_csa -!----------------------------------------------------------------------------- - subroutine write_rbank(jlee,adif,nft) - - use csa_data - use geometry_data, only: nres,rad2deg -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -!el local variables - integer :: nft,i,k,j,l,jlee - real(kind=8) :: adif - - open(icsa_rbank,file=csa_rbank,status="unknown") - write (icsa_rbank,900) jlee,nbank,nstep,nft,icycle,adif - do k=1,nbank - write (icsa_rbank,952) k,rene(k),rrmsn(k),rpncn(k) - do j=1,numch - do l=2,nres-1 - write (icsa_rbank,850) (rad2deg*rvar(i,l,j,k),i=1,4) - enddo - enddo - enddo - close(icsa_rbank) - - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =",& - i8,i10,i2,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& - ' %NC ',0pf5.2) - - return - end subroutine write_rbank -!----------------------------------------------------------------------------- - subroutine read_rbank(jlee,adif) - - use csa_data - use geometry_data, only: nres,deg2rad - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.SETUP' - character(len=80) :: karta -!el local variables - integer :: nbankr,nstepr,nftr,icycler,kk,k,j,l,i,& - ierror,ierrcode,jlee,jleer - real(kind=8) :: adif - - open(icsa_rbank,file=csa_rbank,status="old") - read (icsa_rbank,901) jleer,nbankr,nstepr,nftr,icycler,adif - print *,jleer,nbankr,nstepr,nftr,icycler,adif -! print *, 'adif from read_rbank ',adif -#ifdef MPI - if(nbankr.ne.nbank) then - write (iout,*) 'ERROR in READ_BANK: NBANKR',nbankr,& - ' NBANK',nbank - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - if(jleer.ne.jlee) then - write (iout,*) 'ERROR in READ_BANK: JLEER',jleer,& - ' JLEE',jlee - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -#endif - - kk=0 - do k=1,nbankr - read (icsa_rbank,'(a80)') karta - write(iout,*) "READ_RBANK: kk=",kk - write(iout,*) karta -! if (index(karta,"*").gt.0) then -! write (iout,*) "***** Stars in bankr ***** k=",k, -! & " skipped" -! do j=1,numch -! do l=2,nres-1 -! read (30,850) (rdummy,i=1,4) -! enddo -! enddo -! else - kk=kk+1 - call reada(karta,"total E",rene(kk),1.0d20) - call reada(karta,"rmsd from N",rrmsn(kk),0.0d0) - call reada(karta,"%NC",rpncn(kk),0.0d0) - write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk),& - "%NC",bpncn(kk),ibank(kk) -! read (icsa_rbank,953) kdummy,rene(kk),rrmsn(kk),rpncn(kk) - do j=1,numch - do l=2,nres-1 - read (icsa_rbank,850) (rvar(i,l,j,kk),i=1,4) -! write (iout,850) (rvar(i,l,j,kk),i=1,4) - do i=1,4 - rvar(i,l,j,kk)=deg2rad*rvar(i,l,j,kk) - enddo - enddo - enddo -! endif - enddo -!d write (*,*) "read_rbank ******************* kk",kk, -!d & "nbankr",nbankr - if (kk.lt.nbankr) nbankr=kk -!d do kk=1,nbankr -!d print *,"kk=",kk -!d do j=1,numch -!d do l=2,nres-1 -!d write (*,850) (rvar(i,l,j,kk),i=1,4) -!d enddo -!d enddo -!d enddo - close(icsa_rbank) - - 850 format (10f8.3) - 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) - 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2) - - return - end subroutine read_rbank -!----------------------------------------------------------------------------- - subroutine write_bank(jlee,nft) - - use csa_data - use control_data, only: vdisulf - use geometry_data, only: nres,rad2deg -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' - character(len=7) :: chtmp - character(len=40) :: chfrm -!el external ilen -!el local variables - integer :: nft,k,l,i,j,jlee - - open(icsa_bank,file=csa_bank,status="unknown") - write (icsa_bank,900) jlee,nbank,nstep,nft,icycle,cutdif - write (icsa_bank,902) nglob_csa, eglob_csa - open (igeom,file=intname,status='UNKNOWN') - do k=1,nbank - write (icsa_bank,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) - if (vdisulf) write (icsa_bank,'(101i4)') & - bvar_nss(k),((bvar_ss(j,i,k),j=1,2),i=1,bvar_nss(k)) - do j=1,numch - do l=2,nres-1 - write (icsa_bank,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - if (bvar_nss(k).le.9) then - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& - bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) - else - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& - bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) - write (igeom,'(3X,11(1X,2I3))') (bvar_ss(1,i,k),& - bvar_ss(2,i,k),i=10,bvar_nss(k)) - endif - write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_bank) - close(igeom) - - if (nstep/200.gt.ilastnstep) then - - ilastnstep=(ilastnstep+1)*1.5 - write(chfrm,'(a2,i1,a1)') '(i',int(dlog10(dble(nstep))+1),')' - write(chtmp,chfrm) nstep - open(icsa_int,file=prefix(:ilen(prefix)) & - //'_'//chtmp(:ilen(chtmp))//'.int',status='UNKNOWN') - do k=1,nbank - if (bvar_nss(k).le.9) then - write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& - bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) - else - write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& - bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) - write (icsa_int,'(3X,11(1X,2I3))') (bvar_ss(1,i,k),& - bvar_ss(2,i,k),i=10,bvar_nss(k)) - endif - write (icsa_int,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (icsa_int,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (icsa_int,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (icsa_int,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_int) - endif - - - 200 format (8f10.4) - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =",& - i8,i10,i2,f15.5) - 902 format (1x,'nglob_csa =',i4,' eglob_csa =',1pe14.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& - ' %NC ',0pf5.2,i5) - - return - end subroutine write_bank -!----------------------------------------------------------------------------- - subroutine write_bank_reminimized(jlee,nft) - - use csa_data - use geometry_data, only: nres,rad2deg - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.SBRIDGE' -!el local variables - integer :: nft,i,l,j,k,jlee - - open(icsa_bank_reminimized,file=csa_bank_reminimized,& - status="unknown") - write (icsa_bank_reminimized,900) & - jlee,nbank,nstep,nft,icycle,cutdif - open (igeom,file=intname,status='UNKNOWN') - do k=1,nbank - write (icsa_bank_reminimized,952) k,bene(k),brmsn(k),& - bpncn(k),ibank(k) - do j=1,numch - do l=2,nres-1 - write (icsa_bank_reminimized,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - if (nss.le.9) then - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& - nss,(ihpb(i),jhpb(i),i=1,nss) - else - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k),& - nss,(ihpb(i),jhpb(i),i=1,9) - write (igeom,'(3X,11(1X,2I3))') (ihpb(i),jhpb(i),i=10,nss) - endif - write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_bank_reminimized) - close(igeom) - - 200 format (8f10.4) - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =",& - i8,i10,i2,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& - ' %NC ',0pf5.2,i5) - - return - end subroutine write_bank_reminimized -!----------------------------------------------------------------------------- - subroutine read_bank(jlee,nft,cutdifr) - - use csa_data - use control_data, only: vdisulf - use geometry_data, only: nres,deg2rad - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -! include 'COMMON.CONTROL' -! include 'COMMON.SBRIDGE' - character(len=80) :: karta -! integer ilen -!el external ilen -!el local variables - integer :: nft,kk,k,l,i,j,jlee - real(kind=8) :: cutdifr - - open(icsa_bank,file=csa_bank,status="old") - read (icsa_bank,901) jlee,nbank,nstep,nft,icycle,cutdifr - read (icsa_bank,902) nglob_csa, eglob_csa -! if(jleer.ne.jlee) then -! write (iout,*) 'ERROR in READ_BANK: JLEER',jleer, -! & ' JLEE',jlee -! call mpi_abort(mpi_comm_world,ierror,ierrcode) -! endif - - kk=0 - do k=1,nbank - read (icsa_bank,'(a80)') karta - write(iout,*) "READ_BANK: kk=",kk - write(iout,*) karta -! if (index(karta,"*").gt.0) then -! write (iout,*) "***** Stars in bank ***** k=",k, -! & " skipped" -! do j=1,numch -! do l=2,nres-1 -! read (33,850) (rdummy,i=1,4) -! enddo -! enddo -! else - kk=kk+1 - call reada(karta,"total E",bene(kk),1.0d20) - call reada(karta,"rmsd from N",brmsn(kk),0.0d0) - call reada(karta,"%NC",bpncn(kk),0.0d0) - read (karta(ilen(karta)-1:),*,end=111,err=111) ibank(kk) - goto 112 - 111 ibank(kk)=0 - 112 continue - write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk),& - "%NC",bpncn(kk),ibank(kk) -! read (icsa_bank,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) - if (vdisulf) then - read (icsa_bank,'(101i4)') & - bvar_nss(kk),((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) - bvar_ns(kk)=ns-2*bvar_nss(kk) - write(iout,*) 'read SSBOND',bvar_nss(kk),& - ((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) -!d write(iout,*) 'read CYS #free ', bvar_ns(kk) - l=0 - do i=1,ns - j=1 - do while( iss(i).ne.bvar_ss(1,j,kk)-nres .and. & - iss(i).ne.bvar_ss(2,j,kk)-nres .and. & - j.le.bvar_nss(kk)) - j=j+1 - enddo - if (j.gt.bvar_nss(kk)) then - l=l+1 - bvar_s(l,kk)=iss(i) - endif - enddo -!d write(iout,*)'read CYS free',(bvar_s(l,kk),l=1,bvar_ns(kk)) - endif - do j=1,numch - do l=2,nres-1 - read (icsa_bank,850) (bvar(i,l,j,kk),i=1,4) -! write (iout,850) (bvar(i,l,j,kk),i=1,4) - do i=1,4 - bvar(i,l,j,kk)=deg2rad*bvar(i,l,j,kk) - enddo ! l - enddo ! l - enddo ! j -! endif - enddo ! k - - if (kk.lt.nbank) nbank=kk -!d write (*,*) "read_bank ******************* kk",kk, -!d & "nbank",nbank -!d do kk=1,nbank -!d print *,"kk=",kk -!d do j=1,numch -!d do l=2,nres-1 -!d write (*,850) (bvar(i,l,j,kk),i=1,4) -!d enddo -!d enddo -!d enddo - -! do k=1,nbank -! read (33,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) -! do j=1,numch -! do l=2,nres-1 -! read (33,850) (bvar(i,l,j,k),i=1,4) -! do i=1,4 -! bvar(i,l,j,k)=deg2rad*bvar(i,l,j,k) -! enddo -! enddo -! enddo -! enddo - close(icsa_bank) - - 850 format (10f8.3) - 952 format (1x,'#',i4,' total E ',f12.3,' rmsd from N ',f8.3,i5) - 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) - 902 format (1x,11x,i4,12x,1pe14.5) - 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2,i5) - - return - end subroutine read_bank -!----------------------------------------------------------------------------- - subroutine write_bank1(jlee) - - use csa_data - use geometry_data, only: nres,rad2deg -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' -!el local variables - integer :: k,i,l,j,jlee - -#if defined(AIX) || defined(PGI) - open(icsa_bank1,file=csa_bank1,position="append") -#else - open(icsa_bank1,file=csa_bank1,access="append") -#endif - write (icsa_bank1,900) jlee,nbank,nstep,cutdif - do k=1,nbank - write (icsa_bank1,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) - do j=1,numch - do l=2,nres-1 - write (icsa_bank1,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - enddo - close(icsa_bank1) - 850 format (10f8.3) - 900 format (4x,"jlee =",i5,3x,"nbank =",i5,3x,"nstep =",i10,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3,& - ' %NC ',0pf5.2,i5) - - return - end subroutine write_bank1 -!----------------------------------------------------------------------------- -! cartprint.f -!----------------------------------------------------------------------------- -! subroutine cartprint - -! use geometry_data, only: c -! use energy_data, only: itype -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! integer :: i - -! write (iout,100) -! do i=1,nres -! write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),& -! c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) -! enddo -! 100 format (//' alpha-carbon coordinates ',& -! ' centroid coordinates'/ & -! ' ', 6X,'X',11X,'Y',11X,'Z',& -! 10X,'X',11X,'Y',11X,'Z') -! 110 format (a,'(',i3,')',6f12.5) -! return -! end subroutine cartprint -!----------------------------------------------------------------------------- -! dihed_cons.F -!----------------------------------------------------------------------------- - subroutine secstrp2dihc - - use geometry_data - use energy_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.BOUNDS' -! include 'COMMON.CHAIN' -! include 'COMMON.TORCNSTR' -! include 'COMMON.IOUNITS' -!el character(len=1),dimension(nres) :: secstruc !(maxres) -!el COMMON/SECONDARYS/secstruc - character(len=80) :: line - logical :: errflag -!el external ilen - -!el local variables - integer :: i,ii,lenpre - - allocate(secstruc(nres)) - -!dr call getenv_loc('SECPREDFIL',secpred) - lenpre=ilen(prefix) - secpred=prefix(:lenpre)//'.spred' - -#if defined(WINIFL) || defined(WINPGI) - open(isecpred,file=secpred,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(isecpred,file=secpred,status='old',action='read') -#elif (defined G77) - open(isecpred,file=secpred,status='old') -#else - open(isecpred,file=secpred,status='old',action='read') -#endif -! read secondary structure prediction from JPRED here! -! read(isecpred,'(A80)',err=100,end=100) line -! read(line,'(f10.3)',err=110) ftors - read(isecpred,'(f10.3)',err=110) ftors - - write (iout,*) 'FTORS factor =',ftors -! initialize secstruc to any - do i=1,nres - secstruc(i) ='-' - enddo - ndih_constr=0 - ndih_nconstr=0 - - call read_secstr_pred(isecpred,iout,errflag) - if (errflag) then - write(iout,*)'There is a problem with the list of secondary-',& - 'structure prediction' - goto 100 - endif -! 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - - ii=0 - do i=1,nres - if ( secstruc(i) .eq. 'H') then -! Helix restraints for this residue - ii=ii+1 - idih_constr(ii)=i - phi0(ii) = 45.0D0*deg2rad - drange(ii)= 5.0D0*deg2rad - phibound(1,i) = phi0(ii)-drange(ii) - phibound(2,i) = phi0(ii)+drange(ii) - else if (secstruc(i) .eq. 'E') then -! strand restraints for this residue - ii=ii+1 - idih_constr(ii)=i - phi0(ii) = 180.0D0*deg2rad - drange(ii)= 5.0D0*deg2rad - phibound(1,i) = phi0(ii)-drange(ii) - phibound(2,i) = phi0(ii)+drange(ii) - else -! no restraints for this residue - ndih_nconstr=ndih_nconstr+1 - idih_nconstr(ndih_nconstr)=i - endif - enddo - ndih_constr=ii -! deallocate(secstruc) - return -100 continue - write(iout,'(A30,A80)')'Error reading file SECPRED',secpred -! deallocate(secstruc) - return -110 continue - write(iout,'(A20)')'Error reading FTORS' -! deallocate(secstruc) - return - end subroutine secstrp2dihc -!----------------------------------------------------------------------------- - subroutine read_secstr_pred(jin,jout,errors) - -! implicit real*8 (a-h,o-z) -! INCLUDE 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -!el character(len=1),dimension(nres) :: secstruc !(maxres) -!el COMMON/SECONDARYS/secstruc -!el EXTERNAL ILEN - character(len=80) :: line,line1 !,ucase - logical :: errflag,errors,blankline - -!el local variables - integer :: jin,jout,iseq,ipos,ipos1,iend,il,& - length_of_chain - errors=.false. - read (jin,'(a)') line - write (jout,'(2a)') '> ',line(1:78) - line1=ucase(line) -! Remember that we number full residues starting from 2, then, iseq=1 and iseq=nres -! correspond to the end-groups. ADD to the secondary structure prediction "-" for the -! end-groups in the input file "*.spred" - - iseq=1 - do while (index(line1,'$END').eq.0) -! Override commented lines. - ipos=1 - blankline=.false. - do while (.not.blankline) - line1=' ' - call mykey(line,line1,ipos,blankline,errflag) - if (errflag) write (jout,'(2a)') & - 'Error when reading sequence in line: ',line - errors=errors .or. errflag - if (.not. blankline .and. .not. errflag) then - ipos1=2 - iend=ilen(line1) -!el if (iseq.le.maxres) then - if (line1(1:1).eq.'-' ) then - secstruc(iseq)=line1(1:1) - else if ( ( ucase(line1(1:1)).eq.'E' ) .or. & - ( ucase(line1(1:1)).eq.'H' ) ) then - secstruc(iseq)=ucase(line1(1:1)) - else - errors=.true. - write (jout,1010) line1(1:1), iseq - goto 80 - endif -!el else -!el errors=.true. -!el write (jout,1000) iseq,maxres -!el goto 80 -!el endif - do while (ipos1.le.iend) - - iseq=iseq+1 - il=1 - ipos1=ipos1+1 -!el if (iseq.le.maxres) then - if (line1(ipos1-1:ipos1-1).eq.'-' ) then - secstruc(iseq)=line1(ipos1-1:ipos1-1) - else if((ucase(line1(ipos1-1:ipos1-1)).eq.'E').or. & - (ucase(line1(ipos1-1:ipos1-1)).eq.'H') ) then - secstruc(iseq)=ucase(line1(ipos1-1:ipos1-1)) - else - errors=.true. - write (jout,1010) line1(ipos1-1:ipos1-1), iseq - goto 80 - endif -!el else -!el errors=.true. -!el write (jout,1000) iseq,maxres -!el goto 80 -!el endif - enddo - iseq=iseq+1 - endif - enddo - read (jin,'(a)') line - write (jout,'(2a)') '> ',line(1:78) - line1=ucase(line) - enddo - -!d write (jout,'(10a8)') (sequence(i),i=1,iseq-1) - -!d check whether the found length of the chain is correct. - length_of_chain=iseq-1 - if (length_of_chain .ne. nres) then -! errors=.true. - write (jout,'(a,i4,a,i4,a)') & - 'Error: the number of labels specified in $SEC_STRUC_PRED (' & - ,length_of_chain,') does not match with the number of residues (' & - ,nres,').' - endif - 80 continue - - 1000 format('Error - the number of residues (',i4,& - ') has exceeded maximum (',i4,').') - 1010 format ('Error - unrecognized secondary structure label',a4,& - ' in position',i4) - return - end subroutine read_secstr_pred -!#endif -!----------------------------------------------------------------------------- -! parmread.F -!----------------------------------------------------------------------------- - subroutine parmread - - use geometry_data - use energy_data - use control_data, only:maxtor,maxterm - use MD_data - use MPI_data -!el use map_data - use control, only: getenv_loc -! -! Read the parameters of the probability distributions of the virtual-bond -! valence angles and the side chains and energy parameters. -! -! Important! Energy-term weights ARE NOT read here; they are read from the -! main input file instead, because NO defaults have yet been set for these -! parameters. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer :: IERROR -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.SCCOR' -! include 'COMMON.SCROT' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' -! include 'COMMON.SBRIDGE' -! include 'COMMON.MD' -! include 'COMMON.SETUP' - character(len=1) :: t1,t2,t3 - character(len=1) :: onelett(4) = (/"G","A","P","D"/) - character(len=1) :: toronelet(-2:2) = (/"p","a","G","A","P"/) - logical :: lprint,LaTeX - real(kind=8),dimension(3,3,maxlob) :: blower !(3,3,maxlob) - real(kind=8),dimension(13) :: b - character(len=3) :: lancuch !,ucase -!el local variables - integer :: m,n,l,i,j,k,iblock,lll,llll,ll,nlobi,mm - integer :: maxinter,junk,kk,ii - real(kind=8) :: v0ijsccor,v0ijsccor1,v0ijsccor2,v0ijsccor3,si,& - dwa16,rjunk,akl,v0ij,rri,epsij,rrij,sigeps,sigt1sq,& - sigt2sq,sigii1,sigii2,ratsig1,ratsig2,rsum_max,r_augm,& - res1 - integer :: ichir1,ichir2 -! real(kind=8),dimension(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) :: v1_el,v2_el !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) -!el allocate(v1_el(maxterm,-maxtor:maxtor,-maxtor:maxtor,2)) -!el allocate(v2_el(maxterm,-maxtor:maxtor,-maxtor:maxtor,2)) -! -! For printing parameters after they are read set the following in the UNRES -! C-shell script: -! -! setenv PRINT_PARM YES -! -! To print parameters in LaTeX format rather than as ASCII tables: -! -! setenv LATEX YES -! - call getenv_loc("PRINT_PARM",lancuch) - lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") - call getenv_loc("LATEX",lancuch) - LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") -! - dwa16=2.0d0**(1.0d0/6.0d0) - itypro=20 -! Assign virtual-bond length - vbl=3.8D0 - vblinv=1.0D0/vbl - vblinv2=vblinv*vblinv -! -! Read the virtual-bond parameters, masses, and moments of inertia -! and Stokes' radii of the peptide group and side chains -! - allocate(dsc(ntyp1)) !(ntyp1) - allocate(dsc_inv(ntyp1)) !(ntyp1) - allocate(nbondterm(ntyp)) !(ntyp) - allocate(vbldsc0(maxbondterm,ntyp)) !(maxbondterm,ntyp) - allocate(aksc(maxbondterm,ntyp)) !(maxbondterm,ntyp) - allocate(msc(ntyp+1)) !(ntyp+1) - allocate(isc(ntyp+1)) !(ntyp+1) - allocate(restok(ntyp+1)) !(ntyp+1) - allocate(abond0(maxbondterm,ntyp)) !(maxbondterm,ntyp) - - dsc(:)=0.0d0 - dsc_inv(:)=0.0d0 - -#ifdef CRYST_BOND - read (ibond,*) vbldp0,akp,mp,ip,pstok - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*) vbldsc0(1,i),aksc(1,i),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#else - read (ibond,*) junk,vbldp0,akp,rjunk,mp,ip,pstok - do i=1,ntyp - read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i),& - j=1,nbondterm(i)),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#endif - if (lprint) then - write(iout,'(/a/)')"Dynamic constants of the interaction sites:" - write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass',& - 'inertia','Pstok' - write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok - do i=1,ntyp - write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i),& - vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i) - do j=2,nbondterm(i) - write (iout,'(13x,3f10.5)') & - vbldsc0(j,i),aksc(j,i),abond0(j,i) - enddo - enddo - endif -!---------------------------------------------------- - allocate(a0thet(-ntyp:ntyp),theta0(-ntyp:ntyp)) - allocate(sig0(-ntyp:ntyp),sigc0(-ntyp:ntyp)) !(-ntyp:ntyp) - allocate(athet(2,-ntyp:ntyp,-1:1,-1:1)) - allocate(bthet(2,-ntyp:ntyp,-1:1,-1:1)) !(2,-ntyp:ntyp,-1:1,-1:1) - allocate(polthet(0:3,-ntyp:ntyp)) !(0:3,-ntyp:ntyp) - allocate(gthet(3,-ntyp:ntyp)) !(3,-ntyp:ntyp) - - a0thet(:)=0.0D0 - athet(:,:,:,:)=0.0D0 - bthet(:,:,:,:)=0.0D0 - polthet(:,:)=0.0D0 - gthet(:,:)=0.0D0 - theta0(:)=0.0D0 - sig0(:)=0.0D0 - sigc0(:)=0.0D0 - -#ifdef CRYST_THETA -! -! Read the parameters of the probability distribution/energy expression -! of the virtual-bond valence angles theta -! - do i=1,ntyp - read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i,1,1),j=1,2),& - (bthet(j,i,1,1),j=1,2) - read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - do i=1,ntyp - athet(1,i,1,-1)=athet(1,i,1,1) - athet(2,i,1,-1)=athet(2,i,1,1) - bthet(1,i,1,-1)=-bthet(1,i,1,1) - bthet(2,i,1,-1)=-bthet(2,i,1,1) - athet(1,i,-1,1)=-athet(1,i,1,1) - athet(2,i,-1,1)=-athet(2,i,1,1) - bthet(1,i,-1,1)=bthet(1,i,1,1) - bthet(2,i,-1,1)=bthet(2,i,1,1) - enddo - do i=-ntyp,-1 - a0thet(i)=a0thet(-i) - athet(1,i,-1,-1)=athet(1,-i,1,1) - athet(2,i,-1,-1)=-athet(2,-i,1,1) - bthet(1,i,-1,-1)=bthet(1,-i,1,1) - bthet(2,i,-1,-1)=-bthet(2,-i,1,1) - athet(1,i,-1,1)=athet(1,-i,1,1) - athet(2,i,-1,1)=-athet(2,-i,1,1) - bthet(1,i,-1,1)=-bthet(1,-i,1,1) - bthet(2,i,-1,1)=bthet(2,-i,1,1) - athet(1,i,1,-1)=-athet(1,-i,1,1) - athet(2,i,1,-1)=athet(2,-i,1,1) - bthet(1,i,1,-1)=bthet(1,-i,1,1) - bthet(2,i,1,-1)=-bthet(2,-i,1,1) - theta0(i)=theta0(-i) - sig0(i)=sig0(-i) - sigc0(i)=sigc0(-i) - do j=0,3 - polthet(j,i)=polthet(j,-i) - enddo - do j=1,3 - gthet(j,i)=gthet(j,-i) - enddo - enddo - - close (ithep) - if (lprint) then - if (.not.LaTeX) then - write (iout,'(a)') & - 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:',& - ' ATHETA0 ',' A1 ',' A2 ',& - ' B1 ',' B2 ' - do i=1,ntyp - write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,& - a0thet(i),(athet(j,i,1,1),j=1,2),(bthet(j,i,1,1),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') & - 'Parameters of the expression for sigma(theta_c):',& - ' ALPH0 ',' ALPH1 ',' ALPH2 ',& - ' ALPH3 ',' SIGMA0C ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,& - (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') & - 'Parameters of the second gaussian:',& - ' THETA0 ',' SIGMA0 ',' G1 ',& - ' G2 ',' G3 ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i),& - sig0(i),(gthet(j,i),j=1,3) - enddo - else - write (iout,'(a)') & - 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') & - 'Coefficients of expansion',& - ' theta0 ',' a1*10^2 ',' a2*10^2 ',& - ' b1*10^1 ',' b2*10^1 ' - do i=1,ntyp - write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),& - a0thet(i),(100*athet(j,i,1,1),j=1,2),& - (10*bthet(j,i,1,1),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') & - 'Parameters of the expression for sigma(theta_c):',& - ' alpha0 ',' alph1 ',' alph2 ',& - ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i),& - (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') & - 'Parameters of the second gaussian:',& - ' theta0 ',' sigma0*10^2 ',' G1*10^-1',& - ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i),& - 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif - endif -#else -! -! Read the parameters of Utheta determined from ab initio surfaces -! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -! - read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2,& - ntheterm3,nsingle,ndouble - nntheterm=max0(ntheterm,ntheterm2,ntheterm3) - -!---------------------------------------------------- - allocate(ithetyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) - allocate(aa0thet(-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - allocate(aathet(ntheterm,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(maxtheterm,-maxthetyp1:maxthetyp1,& -! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - allocate(bbthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(ccthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(ddthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(eethet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& -! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - allocate(ffthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(ggthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,& -! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - - read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1) - do i=-ntyp1,-1 - ithetyp(i)=-ithetyp(-i) - enddo - - aa0thet(:,:,:,:)=0.0d0 - aathet(:,:,:,:,:)=0.0d0 - bbthet(:,:,:,:,:,:)=0.0d0 - ccthet(:,:,:,:,:,:)=0.0d0 - ddthet(:,:,:,:,:,:)=0.0d0 - eethet(:,:,:,:,:,:)=0.0d0 - ffthet(:,:,:,:,:,:,:)=0.0d0 - ggthet(:,:,:,:,:,:,:)=0.0d0 - -! VAR:iblock means terminally blocking group 1=non-proline 2=proline - do iblock=1,2 -! VAR:ntethtyp is type of theta potentials type currently 0=glycine -! VAR:1=non-glicyne non-proline 2=proline -! VAR:negative values for D-aminoacid - do i=0,nthetyp - do j=-nthetyp,nthetyp - do k=-nthetyp,nthetyp - read (ithep,'(6a)',end=111,err=111) res1 - read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock) -! VAR: aa0thet is variable describing the average value of Foureir -! VAR: expansion series -! VAR: aathet is foureir expansion in theta/2 angle for full formula -! VAR: look at the fitting equation in Kozlowska et al., J. Phys.: -!ondens. Matter 19 (2007) 285203 and Sieradzan et al., unpublished - read (ithep,*,end=111,err=111) & - (aathet(l,i,j,k,iblock),l=1,ntheterm) - read (ithep,*,end=111,err=111) & - ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - ll=1,ntheterm2) - read (ithep,*,end=111,err=111) & - (((ffthet(llll,lll,ll,i,j,k,iblock),& - ffthet(lll,llll,ll,i,j,k,iblock),& - ggthet(llll,lll,ll,i,j,k,iblock),& - ggthet(lll,llll,ll,i,j,k,iblock),& - llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -! -! For dummy ends assign glycine-type coefficients of theta-only terms; the -! coefficients of theta-and-gamma-dependent terms are zero. -! IF YOU WANT VALENCE POTENTIALS FOR DUMMY ATOM UNCOMENT BELOW (NOT -! RECOMENTDED AFTER VERSION 3.3) -! do i=1,nthetyp -! do j=1,nthetyp -! do l=1,ntheterm -! aathet(l,i,j,nthetyp+1,iblock)=aathet(l,i,j,1,iblock) -! aathet(l,nthetyp+1,i,j,iblock)=aathet(l,1,i,j,iblock) -! enddo -! aa0thet(i,j,nthetyp+1,iblock)=aa0thet(i,j,1,iblock) -! aa0thet(nthetyp+1,i,j,iblock)=aa0thet(1,i,j,iblock) -! enddo -! do l=1,ntheterm -! aathet(l,nthetyp+1,i,nthetyp+1,iblock)=aathet(l,1,i,1,iblock) -! enddo -! aa0thet(nthetyp+1,i,nthetyp+1,iblock)=aa0thet(1,i,1,iblock) -! enddo -! enddo -! AND COMMENT THE LOOPS BELOW - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1,iblock)=0.0d0 - aathet(l,nthetyp+1,i,j,iblock)=0.0d0 - enddo - aa0thet(i,j,nthetyp+1,iblock)=0.0d0 - aa0thet(nthetyp+1,i,j,iblock)=0.0d0 - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 - enddo - aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 - enddo - enddo !iblock - -! TILL HERE -! Substitution for D aminoacids from symmetry. - do iblock=1,2 - do i=-nthetyp,0 - do j=-nthetyp,nthetyp - do k=-nthetyp,nthetyp - aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock) - do l=1,ntheterm - aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock) - enddo - do ll=1,ntheterm2 - do lll=1,nsingle - bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock) - ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock) - ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock) - eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock) - enddo - enddo - do ll=1,ntheterm3 - do lll=2,ndouble - do llll=1,lll-1 - ffthet(llll,lll,ll,i,j,k,iblock)= & - ffthet(llll,lll,ll,-i,-j,-k,iblock) - ffthet(lll,llll,ll,i,j,k,iblock)= & - ffthet(lll,llll,ll,-i,-j,-k,iblock) - ggthet(llll,lll,ll,i,j,k,iblock)= & - -ggthet(llll,lll,ll,-i,-j,-k,iblock) - ggthet(lll,llll,ll,i,j,k,iblock)= & - -ggthet(lll,llll,ll,-i,-j,-k,iblock) - enddo !ll - enddo !lll - enddo !llll - enddo !k - enddo !j - enddo !i - enddo !iblock -! -! Control printout of the coefficients of virtual-bond-angle potentials -! - if (lprint) then - write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' - do iblock=1,2 - do i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') & - 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) - write (iout,'(i2,1pe15.5)') & - (l,aathet(l,i,j,k,iblock),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))') & - "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m,& - bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock),& - ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))') & - "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m,& - ffthet(n,m,l,i,j,k,iblock),& - ffthet(m,n,l,i,j,k,iblock),& - ggthet(n,m,l,i,j,k,iblock),& - ggthet(m,n,l,i,j,k,iblock) - enddo !n - enddo !m - enddo !l - enddo !k - enddo !j - enddo !i - enddo - call flush(iout) - endif - write (2,*) "Start reading THETA_PDB",ithep_pdb - do i=1,ntyp -! write (2,*) 'i=',i - read (ithep_pdb,*,err=111,end=111) & - a0thet(i),(athet(j,i,1,1),j=1,2),& - (bthet(j,i,1,1),j=1,2) - read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - do i=1,ntyp - athet(1,i,1,-1)=athet(1,i,1,1) - athet(2,i,1,-1)=athet(2,i,1,1) - bthet(1,i,1,-1)=-bthet(1,i,1,1) - bthet(2,i,1,-1)=-bthet(2,i,1,1) - athet(1,i,-1,1)=-athet(1,i,1,1) - athet(2,i,-1,1)=-athet(2,i,1,1) - bthet(1,i,-1,1)=bthet(1,i,1,1) - bthet(2,i,-1,1)=bthet(2,i,1,1) - enddo - do i=-ntyp,-1 - a0thet(i)=a0thet(-i) - athet(1,i,-1,-1)=athet(1,-i,1,1) - athet(2,i,-1,-1)=-athet(2,-i,1,1) - bthet(1,i,-1,-1)=bthet(1,-i,1,1) - bthet(2,i,-1,-1)=-bthet(2,-i,1,1) - athet(1,i,-1,1)=athet(1,-i,1,1) - athet(2,i,-1,1)=-athet(2,-i,1,1) - bthet(1,i,-1,1)=-bthet(1,-i,1,1) - bthet(2,i,-1,1)=bthet(2,-i,1,1) - athet(1,i,1,-1)=-athet(1,-i,1,1) - athet(2,i,1,-1)=athet(2,-i,1,1) - bthet(1,i,1,-1)=bthet(1,-i,1,1) - bthet(2,i,1,-1)=-bthet(2,-i,1,1) - theta0(i)=theta0(-i) - sig0(i)=sig0(-i) - sigc0(i)=sigc0(-i) - do j=0,3 - polthet(j,i)=polthet(j,-i) - enddo - do j=1,3 - gthet(j,i)=gthet(j,-i) - enddo - enddo - write (2,*) "End reading THETA_PDB" - close (ithep_pdb) -#endif - close(ithep) - -!------------------------------------------- - allocate(nlob(ntyp1)) !(ntyp1) - allocate(bsc(maxlob,ntyp)) !(maxlob,ntyp) - allocate(censc(3,maxlob,-ntyp:ntyp)) !(3,maxlob,-ntyp:ntyp) - allocate(gaussc(3,3,maxlob,-ntyp:ntyp)) !(3,3,maxlob,-ntyp:ntyp) - - bsc(:,:)=0.0D0 - nlob(:)=0 - nlob(:)=0 - dsc(:)=0.0D0 - censc(:,:,:)=0.0D0 - gaussc(:,:,:,:)=0.0D0 - -#ifdef CRYST_SC -! -! Read the parameters of the probability distribution/energy expression -! of the side chains. -! - do i=1,ntyp - read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3),& - ((blower(k,l,1),l=1,k),k=1,3) - censc(1,1,-i)=censc(1,1,i) - censc(2,1,-i)=censc(2,1,i) - censc(3,1,-i)=-censc(3,1,i) - do j=2,nlob(i) - read (irotam,*,end=112,err=112) bsc(j,i) - read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3),& - ((blower(k,l,j),l=1,k),k=1,3) - censc(1,j,-i)=censc(1,j,i) - censc(2,j,-i)=censc(2,j,i) - censc(3,j,-i)=-censc(3,j,i) -! BSC is amplitude of Gaussian - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - if (((k.eq.3).and.(l.ne.3)) & - .or.((l.eq.3).and.(k.ne.3))) then - gaussc(k,l,j,-i)=-akl - gaussc(l,k,j,-i)=-akl - else - gaussc(k,l,j,-i)=akl - gaussc(l,k,j,-i)=akl - endif - enddo - enddo - enddo - endif - enddo - close (irotam) - if (lprint) then - write (iout,'(/a)') 'Parameters of side-chain local geometry' - do i=1,ntyp - nlobi=nlob(i) - if (nlobi.gt.0) then - if (LaTeX) then - write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i),& - ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) - write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') & - 'log h',(bsc(j,i),j=1,nlobi) - write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') & - 'x',((censc(k,j,i),k=1,3),j=1,nlobi) - do k=1,3 - write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') & - ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) - enddo - else - write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) - write (iout,'(a,f10.4,4(16x,f10.4))') & - 'Center ',(bsc(j,i),j=1,nlobi) - write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3),& - j=1,nlobi) - write (iout,'(a)') - endif - endif - enddo - endif -#else -! -! Read scrot parameters for potentials determined from all-atom AM1 calculations -! added by Urszula Kozlowska 07/11/2007 -! -!el Maximum number of SC local term fitting function coefficiants -!el integer,parameter :: maxsccoef=65 - - allocate(sc_parmin(65,ntyp)) !(maxsccoef,ntyp) - - do i=1,ntyp - read (irotam,*,end=112,err=112) - if (i.eq.10) then - read (irotam,*,end=112,err=112) - else - do j=1,65 - read(irotam,*,end=112,err=112) sc_parmin(j,i) - enddo - endif - enddo -! -! Read the parameters of the probability distribution/energy expression -! of the side chains. -! - write (2,*) "Start reading ROTAM_PDB" - do i=1,ntyp - read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3),& - ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam_pdb,*,end=112,err=112) bsc(j,i) - read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3),& - ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam_pdb) - write (2,*) "End reading ROTAM_PDB" -#endif - close(irotam) - -#ifdef CRYST_TOR -! -! Read torsional parameters in old format -! - allocate(itortyp(ntyp1)) !(-ntyp1:ntyp1) - - read (itorp,*,end=113,err=113) ntortyp,nterm_old - if (lprint)write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - -!el from energy module-------- - allocate(v1(nterm_old,ntortyp,ntortyp)) - allocate(v2(nterm_old,ntortyp,ntortyp)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor) -!el--------------------------- - do i=1,ntortyp - do j=1,ntortyp - read (itorp,'(a)') - do k=1,nterm_old - read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) - write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) - enddo - enddo - endif -#else -! -! Read torsional parameters -! - allocate(itortyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) - read (itorp,*,end=113,err=113) ntortyp -!el from energy module--------- - allocate(nterm(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) - allocate(nlor(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) - - allocate(vlor1(maxlor,-ntortyp:ntortyp,-ntortyp:ntortyp)) !(maxlor,-maxtor:maxtor,-maxtor:maxtor) - allocate(vlor2(maxlor,ntortyp,ntortyp)) - allocate(vlor3(maxlor,ntortyp,ntortyp)) !(maxlor,maxtor,maxtor) - allocate(v0(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) - - allocate(v1(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) - allocate(v2(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) -!el--------------------------- - nterm(:,:,:)=0 - nlor(:,:,:)=0 -!el--------------------------- - - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - do i=-ntyp,-1 - itortyp(i)=-itortyp(-i) - enddo -! itortyp(ntyp1)=ntortyp -! itortyp(-ntyp1)=-ntortyp - do iblock=1,2 - write (iout,*) 'ntortyp',ntortyp - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - read (itorp,*,end=113,err=113) nterm(i,j,iblock),& - nlor(i,j,iblock) - nterm(-i,-j,iblock)=nterm(i,j,iblock) - nlor(-i,-j,iblock)=nlor(i,j,iblock) - v0ij=0.0d0 - si=-1.0d0 - do k=1,nterm(i,j,iblock) - read (itorp,*,end=113,err=113) kk,v1(k,i,j,iblock),& - v2(k,i,j,iblock) - v1(k,-i,-j,iblock)=v1(k,i,j,iblock) - v2(k,-i,-j,iblock)=-v2(k,i,j,iblock) - v0ij=v0ij+si*v1(k,i,j,iblock) - si=-si -! write(iout,*) i,j,k,iblock,nterm(i,j,iblock) ! -! write(iout,*) v1(k,-i,-j,iblock),v1(k,i,j,iblock),&! -! v2(k,-i,-j,iblock),v2(k,i,j,iblock)! - enddo - do k=1,nlor(i,j,iblock) - read (itorp,*,end=113,err=113) kk,vlor1(k,i,j),& - vlor2(k,i,j),vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j,iblock)=v0ij - v0(-i,-j,iblock)=v0ij - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do iblock=1,2 - do i=-ntortyp,ntortyp - do j=-ntortyp,ntortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm(i,j,iblock) - write (iout,'(2(1pe15.5))') v1(k,i,j,iblock),& - v2(k,i,j,iblock) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j,iblock) - write (iout,'(3(1pe15.5))') & - vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - enddo - enddo - enddo - enddo - endif -!elwrite (iout,'(/a/)') 'Torsional constants:',vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) -! -! 6/23/01 Read parameters for double torsionals -! -!el from energy module------------ - allocate(v1c(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - allocate(v1s(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) -!(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) - allocate(v2c(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - allocate(v2s(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) - allocate(ntermd_1(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - allocate(ntermd_2(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) -!--------------------------------- - - do iblock=1,2 - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - do k=-ntortyp+1,ntortyp-1 - read (itordp,'(3a1)',end=114,err=114) t1,t2,t3 -! write (iout,*) "OK onelett", -! & i,j,k,t1,t2,t3 - - if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j) & - .or. t3.ne.toronelet(k)) then - write (iout,*) "Error in double torsional parameter file",& - i,j,k,t1,t2,t3 -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop "Error in double torsional parameter file" - endif - read (itordp,*,end=114,err=114) ntermd_1(i,j,k,iblock),& - ntermd_2(i,j,k,iblock) - ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock) - ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock) - read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) - read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) - read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) - read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) -! Martix of D parameters for one dimesional foureir series - do l=1,ntermd_1(i,j,k,iblock) - v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock) - v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock) - v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock) - v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock) -! write(iout,*) "whcodze" , -! & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock) - enddo - read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k,iblock),& - v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock),& - v2s(m,l,i,j,k,iblock),& - m=1,l-1),l=1,ntermd_2(i,j,k,iblock)) -! Martix of D parameters for two dimesional fourier series - do l=1,ntermd_2(i,j,k,iblock) - do m=1,l-1 - v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock) - v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock) - v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock) - v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock) - enddo!m - enddo!l - enddo!k - enddo!j - enddo!i - enddo!iblock - if (lprint) then - write (iout,*) - write (iout,*) 'Constants for double torsionals' - do iblock=1,2 - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - do k=-ntortyp+1,ntortyp-1 - write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,& - ' nsingle',ntermd_1(i,j,k,iblock),& - ' ndouble',ntermd_2(i,j,k,iblock) - write (iout,*) - write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k,iblock) - write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l,& - v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock),& - v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock),& - v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock) - enddo - write (iout,*) - write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) - do l=1,ntermd_2(i,j,k,iblock) - write (iout,'(i5,20f10.5)') & - l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)) - enddo - write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) - do l=1,ntermd_2(i,j,k,iblock) - write (iout,'(i5,20f10.5)') & - l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)),& - (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock)) - enddo - write (iout,*) - enddo - enddo - enddo - enddo - endif -#endif -! Read of Side-chain backbone correlation parameters -! Modified 11 May 2012 by Adasko -!CC -! - read (isccor,*,end=119,err=119) nsccortyp - -!el from module energy------------- - allocate(nlor_sccor(nsccortyp,nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) - allocate(vlor1sccor(maxterm_sccor,nsccortyp,nsccortyp)) - allocate(vlor2sccor(maxterm_sccor,nsccortyp,nsccortyp)) - allocate(vlor3sccor(maxterm_sccor,nsccortyp,nsccortyp)) !(maxterm_sccor,20,20) -!----------------------------------- -#ifdef SCCORPDB -!el from module energy------------- - allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) - - read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) - do i=-ntyp,-1 - isccortyp(i)=-isccortyp(-i) - enddo - iscprol=isccortyp(20) -! write (iout,*) 'ntortyp',ntortyp - maxinter=3 -!c maxinter is maximum interaction sites -!el from module energy--------- - allocate(nterm_sccor(-nsccortyp:nsccortyp,-nsccortyp:nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) - allocate(v1sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& - -nsccortyp:nsccortyp)) - allocate(v2sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& - -nsccortyp:nsccortyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) - allocate(v0sccor(maxinter,-nsccortyp:nsccortyp,& - -nsccortyp:nsccortyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) -!----------------------------------- - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*,end=119,err=119) & - nterm_sccor(i,j),nlor_sccor(i,j) - v0ijsccor=0.0d0 - v0ijsccor1=0.0d0 - v0ijsccor2=0.0d0 - v0ijsccor3=0.0d0 - si=-1.0d0 - nterm_sccor(-i,j)=nterm_sccor(i,j) - nterm_sccor(-i,-j)=nterm_sccor(i,j) - nterm_sccor(i,-j)=nterm_sccor(i,j) - do k=1,nterm_sccor(i,j) - read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j),& - v2sccor(k,l,i,j) - if (j.eq.iscprol) then - if (i.eq.isccortyp(10)) then - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - else - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0 & - +v2sccor(k,l,i,j)*dsqrt(0.75d0) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0 & - +v1sccor(k,l,i,j)*dsqrt(0.75d0) - v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) - endif - else - if (i.eq.isccortyp(10)) then - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - else - if (j.eq.isccortyp(10)) then - v1sccor(k,l,-i,j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j) - else - v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) - endif - endif - endif - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j) - v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j) - v0ijsccor3=v0ijsccor+si*v1sccor(k,l,-i,-j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j),& - vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ & - (1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(l,i,j)=v0ijsccor - v0sccor(l,-i,j)=v0ijsccor1 - v0sccor(l,i,-j)=v0ijsccor2 - v0sccor(l,-i,-j)=v0ijsccor3 - enddo - enddo - enddo - close (isccor) -#else -!el from module energy------------- - allocate(isccortyp(ntyp)) !(-ntyp:ntyp) - - read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) -! write (iout,*) 'ntortyp',ntortyp - maxinter=3 -!c maxinter is maximum interaction sites -!el from module energy--------- - allocate(nterm_sccor(nsccortyp,nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) - allocate(v1sccor(maxterm_sccor,maxinter,nsccortyp,nsccortyp)) - allocate(v2sccor(maxterm_sccor,maxinter,nsccortyp,nsccortyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) - allocate(v0sccor(maxinter,nsccortyp,nsccortyp)) !???(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) -!----------------------------------- - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*,end=119,err=119) & - nterm_sccor(i,j),nlor_sccor(i,j) - v0ijsccor=0.0d0 - si=-1.0d0 - - do k=1,nterm_sccor(i,j) - read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j),& - v2sccor(k,l,i,j) - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j),& - vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ & - (1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(l,i,j)=v0ijsccor !el ,iblock - enddo - enddo - enddo - close (isccor) - -#endif - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,nsccortyp - do j=1,nsccortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm_sccor(i,j) - write (iout,'(2(1pe15.5))') v1sccor(k,l,i,j),v2sccor(k,l,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor_sccor(i,j) - write (iout,'(3(1pe15.5))') & - vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) - enddo - enddo - enddo - endif - -! -! 9/18/99 (AL) Read coefficients of the Fourier expansion of the local -! interaction energy of the Gly, Ala, and Pro prototypes. -! - - if (lprint) then - write (iout,*) - write (iout,*) "Coefficients of the cumulants" - endif - read (ifourier,*) nloctyp -!write(iout,*) "nloctyp",nloctyp -!el from module energy------- - allocate(b1(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) - allocate(b2(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) - allocate(b1tilde(2,-nloctyp+1:nloctyp+1)) !(2,-maxtor:maxtor) - allocate(cc(2,2,-nloctyp-1:nloctyp+1)) - allocate(dd(2,2,-nloctyp-1:nloctyp+1)) - allocate(ee(2,2,-nloctyp-1:nloctyp+1)) - allocate(ctilde(2,2,-nloctyp-1:nloctyp+1)) - allocate(dtilde(2,2,-nloctyp-1:nloctyp+1)) !(2,2,-maxtor:maxtor) -! el - b1(1,:)=0.0d0 - b1(2,:)=0.0d0 -!-------------------------------- - - do i=0,nloctyp-1 - read (ifourier,*,end=115,err=115) - read (ifourier,*,end=115,err=115) (b(ii),ii=1,13) - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii),ii=1,13) - endif - B1(1,i) = b(3) - B1(2,i) = b(5) - B1(1,-i) = b(3) - B1(2,-i) = -b(5) -! b1(1,i)=0.0d0 -! b1(2,i)=0.0d0 - B1tilde(1,i) = b(3) - B1tilde(2,i) =-b(5) - B1tilde(1,-i) =-b(3) - B1tilde(2,-i) =b(5) -! b1tilde(1,i)=0.0d0 -! b1tilde(2,i)=0.0d0 - B2(1,i) = b(2) - B2(2,i) = b(4) - B2(1,-i) =b(2) - B2(2,-i) =-b(4) - -! b2(1,i)=0.0d0 -! b2(2,i)=0.0d0 - CC(1,1,i)= b(7) - CC(2,2,i)=-b(7) - CC(2,1,i)= b(9) - CC(1,2,i)= b(9) - CC(1,1,-i)= b(7) - CC(2,2,-i)=-b(7) - CC(2,1,-i)=-b(9) - CC(1,2,-i)=-b(9) -! CC(1,1,i)=0.0d0 -! CC(2,2,i)=0.0d0 -! CC(2,1,i)=0.0d0 -! CC(1,2,i)=0.0d0 - Ctilde(1,1,i)=b(7) - Ctilde(1,2,i)=b(9) - Ctilde(2,1,i)=-b(9) - Ctilde(2,2,i)=b(7) - Ctilde(1,1,-i)=b(7) - Ctilde(1,2,-i)=-b(9) - Ctilde(2,1,-i)=b(9) - Ctilde(2,2,-i)=b(7) - -! Ctilde(1,1,i)=0.0d0 -! Ctilde(1,2,i)=0.0d0 -! Ctilde(2,1,i)=0.0d0 -! Ctilde(2,2,i)=0.0d0 - DD(1,1,i)= b(6) - DD(2,2,i)=-b(6) - DD(2,1,i)= b(8) - DD(1,2,i)= b(8) - DD(1,1,-i)= b(6) - DD(2,2,-i)=-b(6) - DD(2,1,-i)=-b(8) - DD(1,2,-i)=-b(8) -! DD(1,1,i)=0.0d0 -! DD(2,2,i)=0.0d0 -! DD(2,1,i)=0.0d0 -! DD(1,2,i)=0.0d0 - Dtilde(1,1,i)=b(6) - Dtilde(1,2,i)=b(8) - Dtilde(2,1,i)=-b(8) - Dtilde(2,2,i)=b(6) - Dtilde(1,1,-i)=b(6) - Dtilde(1,2,-i)=-b(8) - Dtilde(2,1,-i)=b(8) - Dtilde(2,2,-i)=b(6) - -! Dtilde(1,1,i)=0.0d0 -! Dtilde(1,2,i)=0.0d0 -! Dtilde(2,1,i)=0.0d0 -! Dtilde(2,2,i)=0.0d0 - EE(1,1,i)= b(10)+b(11) - EE(2,2,i)=-b(10)+b(11) - EE(2,1,i)= b(12)-b(13) - EE(1,2,i)= b(12)+b(13) - EE(1,1,-i)= b(10)+b(11) - EE(2,2,-i)=-b(10)+b(11) - EE(2,1,-i)=-b(12)+b(13) - EE(1,2,-i)=-b(12)-b(13) - -! ee(1,1,i)=1.0d0 -! ee(2,2,i)=1.0d0 -! ee(2,1,i)=0.0d0 -! ee(1,2,i)=0.0d0 -! ee(2,1,i)=ee(1,2,i) - enddo - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) - enddo - enddo - endif -! -! Read electrostatic-interaction parameters -! - - if (lprint) then - write (iout,*) - write (iout,'(/a)') 'Electrostatic interaction constants:' - write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') & - 'IT','JT','APP','BPP','AEL6','AEL3' - endif - read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) - close (ielep) - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - app (i,j)=epp(i,j)*rri*rri - bpp (i,j)=-2.0D0*epp(i,j)*rri - ael6(i,j)=elpp6(i,j)*4.2D0**6 - ael3(i,j)=elpp3(i,j)*4.2D0**3 -! lprint=.true. - if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j),& - ael6(i,j),ael3(i,j) -! lprint=.false. - enddo - enddo -! -! Read side-chain interaction parameters. -! -!el from module energy - COMMON.INTERACT------- - allocate(eps(ntyp,ntyp),sigmaii(ntyp,ntyp),rs0(ntyp,ntyp)) !(ntyp,ntyp) - allocate(augm(ntyp,ntyp)) !(ntyp,ntyp) - allocate(eps_scp(ntyp,2),rscp(ntyp,2)) !(ntyp,2) - allocate(sigma0(ntyp),rr0(ntyp),sigii(ntyp)) !(ntyp) - allocate(chip(ntyp1),alp(ntyp1)) !(ntyp) - - augm(:,:)=0.0D0 - chip(:)=0.0D0 - alp(:)=0.0D0 - sigma0(:)=0.0D0 - sigii(:)=0.0D0 - rr0(:)=0.0D0 - -!-------------------------------- - - read (isidep,*,end=117,err=117) ipot,expon - if (ipot.lt.1 .or. ipot.gt.5) then - write (iout,'(2a)') 'Error while reading SC interaction',& - 'potential file - unknown potential type.' -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - endif - expon2=expon/2 - if(me.eq.king) & - write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot),& - ', exponents are ',expon,2*expon -! goto (10,20,30,30,40) ipot - select case(ipot) -!----------------------- LJ potential --------------------------------- - case (1) -! 10 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& - read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& - (sigma0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJ potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,a)') 'residue','sigma' - write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) - endif -! goto 50 -!----------------------- LJK potential -------------------------------- - case(2) -! 20 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& - read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& - (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i),& - i=1,ntyp) - endif -! goto 50 -!---------------------- GB or BP potential ----------------------------- - case(3:4) -! 30 do i=1,ntyp - do i=1,ntyp - read (isidep,*,end=117,err=117)(eps(i,j),j=i,ntyp) - enddo - read (isidep,*,end=117,err=117)(sigma0(i),i=1,ntyp) - read (isidep,*,end=117,err=117)(sigii(i),i=1,ntyp) - read (isidep,*,end=117,err=117)(chip(i),i=1,ntyp) - read (isidep,*,end=117,err=117)(alp(i),i=1,ntyp) -! For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) - enddo - endif - if (lprint) then - write (iout,'(/a/)') 'Parameters of the BP potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2',& - ' chip ',' alph ' - write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i),& - chip(i),alp(i),i=1,ntyp) - endif -! goto 50 -!--------------------- GBV potential ----------------------------------- - case(5) -! 40 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& - read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp),& - (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp),& - (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ',& - 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i),& - sigii(i),chip(i),alp(i),i=1,ntyp) - endif - case default - write(iout,*)"Wrong ipot" -! 50 continue - end select - continue - close (isidep) -!----------------------------------------------------------------------- -! Calculate the "working" parameters of SC interactions. - -!el from module energy - COMMON.INTERACT------- - allocate(aa(ntyp1,ntyp1),bb(ntyp1,ntyp1),chi(ntyp1,ntyp1)) !(ntyp,ntyp) - allocate(sigma(0:ntyp1,0:ntyp1),r0(ntyp1,ntyp1)) !(0:ntyp1,0:ntyp1) - aa(:,:)=0.0D0 - bb(:,:)=0.0D0 - chi(:,:)=0.0D0 - sigma(:,:)=0.0D0 - r0(:,:)=0.0D0 - -!-------------------------------- - - do i=2,ntyp - do j=1,i-1 - eps(i,j)=eps(j,i) - enddo - enddo - do i=1,ntyp - do j=i,ntyp - sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) - sigma(j,i)=sigma(i,j) - rs0(i,j)=dwa16*sigma(i,j) - rs0(j,i)=rs0(i,j) - enddo - enddo - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') & - 'Working parameters of the SC interactions:',& - ' a ',' b ',' augm ',' sigma ',' r0 ',& - ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - if (ipot.gt.2) then - sigt1sq=sigma0(i)**2 - sigt2sq=sigma0(j)**2 - sigii1=sigii(i) - sigii2=sigii(j) - ratsig1=sigt2sq/sigt1sq - ratsig2=1.0D0/ratsig1 - chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) - if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) - rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) - else - rsum_max=sigma(i,j) - endif -! if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - sigmaii(i,j)=rsum_max - sigmaii(j,i)=rsum_max -! else -! sigmaii(i,j)=r0(i,j) -! sigmaii(j,i)=r0(i,j) -! endif -!d write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max - if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then - r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij - augm(i,j)=epsij*r_augm**(2*expon) -! augm(i,j)=0.5D0**(2*expon)*aa(i,j) - augm(j,i)=augm(i,j) - else - augm(i,j)=0.0D0 - augm(j,i)=0.0D0 - endif - if (lprint) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') & - restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j),& - sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - endif - enddo - enddo - - allocate(aad(ntyp,2),bad(ntyp,2)) !(ntyp,2) - bad(:,:)=0.0D0 - -#ifdef OLDSCP -! -! Define the SC-p interaction constants (hard-coded; old style) -! - do i=1,ntyp -! "Soft" SC-p repulsion (causes helices to be too flat, but facilitates -! helix formation) -! aad(i,1)=0.3D0*4.0D0**12 -! Following line for constants currently implemented -! "Hard" SC-p repulsion (gives correct turn spacing in helices) - aad(i,1)=1.5D0*4.0D0**12 -! aad(i,1)=0.17D0*5.6D0**12 - aad(i,2)=aad(i,1) -! "Soft" SC-p repulsion - bad(i,1)=0.0D0 -! Following line for constants currently implemented -! aad(i,1)=0.3D0*4.0D0**6 -! "Hard" SC-p repulsion - bad(i,1)=3.0D0*4.0D0**6 -! bad(i,1)=-2.0D0*0.17D0*5.6D0**6 - bad(i,2)=bad(i,1) -! aad(i,1)=0.0D0 -! aad(i,2)=0.0D0 -! bad(i,1)=1228.8D0 -! bad(i,2)=1228.8D0 - enddo -#else -! -! 8/9/01 Read the SC-p interaction constants from file -! - do i=1,ntyp - read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) - enddo - do i=1,ntyp - aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 - aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 - bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 - bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 - enddo -! lprint=.true. - if (lprint) then - write (iout,*) "Parameters of SC-p interactions:" - do i=1,ntyp - write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1),& - eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) - enddo - endif -! lprint=.false. -#endif -! -! Define the constants of the disulfide bridge -! - ebr=-5.50D0 -! -! Old arbitrary potential - commented out. -! -! dbr= 4.20D0 -! fbr= 3.30D0 -! -! Constants of the disulfide-bond potential determined based on the RHF/6-31G** -! energy surface of diethyl disulfide. -! A. Liwo and U. Kozlowska, 11/24/03 -! - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 -! akcm=0.0d0 -! akth=0.0d0 -! akct=0.0d0 -! v1ss=0.0d0 -! v2ss=0.0d0 -! v3ss=0.0d0 - - if(me.eq.king) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,& - ' v3ss:',v3ss - endif - return - 111 write (iout,*) "Error reading bending energy parameters." - goto 999 - 112 write (iout,*) "Error reading rotamer energy parameters." - goto 999 - 113 write (iout,*) "Error reading torsional energy parameters." - goto 999 - 114 write (iout,*) "Error reading double torsional energy parameters." - goto 999 - 115 write (iout,*) & - "Error reading cumulant (multibody energy) parameters." - goto 999 - 116 write (iout,*) "Error reading electrostatic energy parameters." - goto 999 - 117 write (iout,*) "Error reading side chain interaction parameters." - goto 999 - 118 write (iout,*) "Error reading SCp interaction parameters." - goto 999 - 119 write (iout,*) "Error reading SCCOR parameters" - 999 continue -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - return - end subroutine parmread -#endif -!----------------------------------------------------------------------------- -! printmat.f -!----------------------------------------------------------------------------- - subroutine printmat(ldim,m,n,iout,key,a) - - integer :: n,ldim - character(len=3),dimension(n) :: key - real(kind=8),dimension(ldim,n) :: a -!el local variables - integer :: i,j,k,m,iout,nlim - - do 1 i=1,n,8 - nlim=min0(i+7,n) - write (iout,1000) (key(k),k=i,nlim) - write (iout,1020) - 1000 format (/5x,8(6x,a3)) - 1020 format (/80(1h-)/) - do 2 j=1,n - write (iout,1010) key(j),(a(j,k),k=i,nlim) - 2 continue - 1 continue - 1010 format (a3,2x,8(f9.4)) - return - end subroutine printmat -!----------------------------------------------------------------------------- -! readpdb.F -!----------------------------------------------------------------------------- - subroutine readpdb -! Read the PDB file and convert the peptide geometry into virtual-chain -! geometry. - use geometry_data - use energy_data, only: itype - use control_data - use compare_data - use MPI_data - use control, only: rescode -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.LOCAL' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.NAMES' -! include 'COMMON.CONTROL' -! include 'COMMON.DISTFIT' -! include 'COMMON.SETUP' - integer :: i,j,ibeg,ishift1,ires,iii,ires_old,ishift!,ity!,& -! ishift_pdb - logical :: lprn=.true.,fail - real(kind=8),dimension(3) :: e1,e2,e3 - real(kind=8) :: dcj,efree_temp - character(len=3) :: seq,res - character(len=5) :: atom - character(len=80) :: card - real(kind=8),dimension(3,20) :: sccor - integer :: kkk,lll,icha,kupa !rescode, - real(kind=8) :: cou -!el local varables - integer,dimension(2,maxres/3) :: hfrag_alloc - integer,dimension(4,maxres/3) :: bfrag_alloc - real(kind=8),dimension(3,maxres2+2,maxperm) :: cref_alloc !(3,maxres2+2,maxperm) - - efree_temp=0.0d0 - ibeg=1 - ishift1=0 - ishift=0 -! write (2,*) "UNRES_PDB",unres_pdb - ires=0 - ires_old=0 - nres=0 - iii=0 - lsecondary=.false. - nhfrag=0 - nbfrag=0 -!----------------------------- - allocate(hfrag(2,maxres/3)) !(2,maxres/3) - allocate(bfrag(4,maxres/3)) !(4,maxres/3) - - do i=1,100000 - read (ipdbin,'(a80)',end=10) card -! write (iout,'(a)') card - if (card(:5).eq.'HELIX') then - nhfrag=nhfrag+1 - lsecondary=.true. - read(card(22:25),*) hfrag(1,nhfrag) - read(card(34:37),*) hfrag(2,nhfrag) - endif - if (card(:5).eq.'SHEET') then - nbfrag=nbfrag+1 - lsecondary=.true. - read(card(24:26),*) bfrag(1,nbfrag) - read(card(35:37),*) bfrag(2,nbfrag) -!rc---------------------------------------- -!rc to be corrected !!! - bfrag(3,nbfrag)=bfrag(1,nbfrag) - bfrag(4,nbfrag)=bfrag(2,nbfrag) -!rc---------------------------------------- - endif - if (card(:3).eq.'END') then - goto 10 - else if (card(:3).eq.'TER') then -! End current chain - ires_old=ires+1 - ishift1=ishift1+1 - itype(ires_old)=ntyp1 - ibeg=2 -! write (iout,*) "Chain ended",ires,ishift,ires_old - if (unres_pdb) then - do j=1,3 - dc(j,ires)=sccor(j,iii) - enddo - else - call sccenter(ires,iii,sccor) - endif - iii=0 - endif -! Read free energy - if (index(card,"FREE ENERGY").gt.0) read(card(35:),*) efree_temp -! Fish out the ATOM cards. - if (index(card(1:4),'ATOM').gt.0) then - read (card(12:16),*) atom -! write (iout,*) "! ",atom," !",ires -! if (atom.eq.'CA' .or. atom.eq.'CH3') then - read (card(23:26),*) ires - read (card(18:20),'(a3)') res -! write (iout,*) "ires",ires,ires-ishift+ishift1, -! & " ires_old",ires_old -! write (iout,*) "ishift",ishift," ishift1",ishift1 -! write (iout,*) "IRES",ires-ishift+ishift1,ires_old - if (ires-ishift+ishift1.ne.ires_old) then -! Calculate the CM of the preceding residue. -! if (ibeg.eq.0) call sccenter(ires,iii,sccor) - if (ibeg.eq.0) then -! write (iout,*) "Calculating sidechain center iii",iii - if (unres_pdb) then - do j=1,3 - dc(j,ires+nres)=sccor(j,iii) - enddo - else - call sccenter(ires_old,iii,sccor) - endif - iii=0 - endif -! Start new residue. - if (res.eq.'Cl-' .or. res.eq.'Na+') then - ires=ires_old - cycle - else if (ibeg.eq.1) then - write (iout,*) "BEG ires",ires - ishift=ires-1 - if (res.ne.'GLY' .and. res.ne. 'ACE') then - ishift=ishift-1 - itype(1)=ntyp1 - endif - ires=ires-ishift+ishift1 - ires_old=ires -! write (iout,*) "ishift",ishift," ires",ires,& -! " ires_old",ires_old - ibeg=0 - else if (ibeg.eq.2) then -! Start a new chain - ishift=-ires_old+ires-1 !!!!! - ishift1=ishift1-1 !!!!! -! write (iout,*) "New chain started",ires,ishift,ishift1,"!" - ires=ires-ishift+ishift1 - ires_old=ires - ibeg=0 - else - ishift=ishift-(ires-ishift+ishift1-ires_old-1) - ires=ires-ishift+ishift1 - ires_old=ires - endif - if (res.eq.'ACE' .or. res.eq.'NHE') then - itype(ires)=10 - else - itype(ires)=rescode(ires,res,0) - endif - else - ires=ires-ishift+ishift1 - endif -! write (iout,*) "ires_old",ires_old," ires",ires - if (card(27:27).eq."A" .or. card(27:27).eq."B") then -! ishift1=ishift1+1 - endif -! write (2,*) "ires",ires," res ",res!," ity"!,ity - if (atom.eq.'CA' .or. atom.eq.'CH3' .or. & - res.eq.'NHE'.and.atom(:2).eq.'HN') then - read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) -! write (iout,*) "backbone ",atom -#ifdef DEBUG - write (iout,'(2i3,2x,a,3f8.3)') & - ires,itype(ires),res,(c(j,ires),j=1,3) -#endif - iii=iii+1 - do j=1,3 - sccor(j,iii)=c(j,ires) - enddo -! write (*,*) card(23:27),ires,itype(ires) - else if (atom.ne.'O'.and.atom(1:1).ne.'H' .and. & - atom.ne.'N' .and. atom.ne.'C' .and. & - atom(:2).ne.'1H' .and. atom(:2).ne.'2H' .and. & - atom.ne.'OXT' .and. atom(:2).ne.'3H') then -! write (iout,*) "sidechain ",atom - iii=iii+1 - read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) - endif - endif - enddo - 10 write (iout,'(a,i5)') ' Number of residues found: ',ires - if (ires.eq.0) return -! Calculate dummy residue coordinates inside the "chain" of a multichain -! system - nres=ires - do i=2,nres-1 -! write (iout,*) i,itype(i) - if (itype(i).eq.ntyp1) then -! write (iout,*) "dummy",i,itype(i) - do j=1,3 - c(j,i)=((c(j,i-1)+c(j,i+1))/2+2*c(j,i-1)-c(j,i-2))/2 -! c(j,i)=(c(j,i-1)+c(j,i+1))/2 - dc(j,i)=c(j,i) - enddo - endif - enddo -! Calculate the CM of the last side chain. - if (iii.gt.0) then - if (unres_pdb) then - do j=1,3 - dc(j,ires)=sccor(j,iii) - enddo - else - call sccenter(ires,iii,sccor) - endif - endif -! nres=ires - nsup=nres - nstart_sup=1 - if (itype(nres).ne.10) then - nres=nres+1 - itype(nres)=ntyp1 - if (unres_pdb) then -! 2/15/2013 by Adam: corrected insertion of the last dummy residue - call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail) - if (fail) then - e2(1)=0.0d0 - e2(2)=1.0d0 - e2(3)=0.0d0 - endif - do j=1,3 - c(j,nres)=c(j,nres-1)-3.8d0*e2(j) - enddo - else - do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) - c(j,nres)=c(j,nres-1)+dcj - c(j,2*nres)=c(j,nres) - enddo - endif - endif -!el kontrola nres w pliku inputowym WHAM-a w porownaniu z wartoscia wczytana z pliku pdb -#ifdef WHAM_RUN - if (nres.ne.nres0) then - write (iout,*) "Error: wrong parameter value: NRES=",nres,& - " NRES0=",nres0 - stop "Error nres value in WHAM input" - endif -#endif -!--------------------------------- -!el reallocate tables -! do i=1,maxres/3 -! do j=1,2 -! hfrag_alloc(j,i)=hfrag(j,i) -! enddo -! do j=1,4 -! bfrag_alloc(j,i)=bfrag(j,i) -! enddo -! enddo - -! deallocate(hfrag) -! deallocate(bfrag) -! allocate(hfrag(2,nres/3)) !(2,maxres/3) -!el allocate(hfrag(2,nhfrag)) !(2,maxres/3) -!el allocate(bfrag(4,nbfrag)) !(4,maxres/3) -! allocate(bfrag(4,nres/3)) !(4,maxres/3) - -! do i=1,nhfrag -! do j=1,2 -! hfrag(j,i)=hfrag_alloc(j,i) -! enddo -! enddo -! do i=1,nbfrag -! do j=1,4 -! bfrag(j,i)=bfrag_alloc(j,i) -! enddo -! enddo -!el end reallocate tables -!--------------------------------- - do i=2,nres-1 - do j=1,3 - c(j,i+nres)=dc(j,i) - enddo - enddo - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - if (itype(1).eq.ntyp1) then - nsup=nsup-1 - nstart_sup=2 - if (unres_pdb) then -! 2/15/2013 by Adam: corrected insertion of the first dummy residue - call refsys(2,3,4,e1,e2,e3,fail) - if (fail) then - e2(1)=0.0d0 - e2(2)=1.0d0 - e2(3)=0.0d0 - endif - do j=1,3 - c(j,1)=c(j,2)-3.8d0*e2(j) - enddo - else - do j=1,3 - dcj=c(j,4)-c(j,3) - c(j,1)=c(j,2)-dcj - c(j,nres+1)=c(j,1) - enddo - endif - endif -! Copy the coordinates to reference coordinates -! do i=1,2*nres -! do j=1,3 -! cref(j,i)=c(j,i) -! enddo -! enddo -! Calculate internal coordinates. - if (lprn) then - write (iout,'(/a)') & - "Cartesian coordinates of the reference structure" - write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & - "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" - do ires=1,nres - write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & - restyp(itype(ires)),ires,(c(j,ires),j=1,3),& - (c(j,ires+nres),j=1,3) - enddo - endif -! znamy już nres wiec mozna alokowac tablice -! Calculate internal coordinates. - if(me.eq.king.or..not.out1file)then - write (iout,'(a)') & - "Backbone and SC coordinates as read from the PDB" - do ires=1,nres - write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') & - ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3),& - (c(j,nres+ires),j=1,3) - enddo - endif - - if(.not.allocated(vbld)) then - allocate(vbld(2*nres)) - do i=1,2*nres - vbld(i)=0.d0 - enddo - endif - if(.not.allocated(vbld_inv)) then - allocate(vbld_inv(2*nres)) - do i=1,2*nres - vbld_inv(i)=0.d0 - enddo - endif -!!!el - if(.not.allocated(theta)) then - allocate(theta(nres+2)) - theta(:)=0.0d0 - endif - - if(.not.allocated(phi)) allocate(phi(nres+2)) - if(.not.allocated(alph)) allocate(alph(nres+2)) - if(.not.allocated(omeg)) allocate(omeg(nres+2)) - if(.not.allocated(thetaref)) allocate(thetaref(nres+2)) - if(.not.allocated(phiref)) allocate(phiref(nres+2)) - if(.not.allocated(costtab)) allocate(costtab(nres)) - if(.not.allocated(sinttab)) allocate(sinttab(nres)) - if(.not.allocated(cost2tab)) allocate(cost2tab(nres)) - if(.not.allocated(sint2tab)) allocate(sint2tab(nres)) - if(.not.allocated(xxref)) allocate(xxref(nres)) - if(.not.allocated(yyref)) allocate(yyref(nres)) - if(.not.allocated(zzref)) allocate(zzref(nres)) !(maxres) - if(.not.allocated(dc_norm)) then -! if(.not.allocated(dc_norm)) allocate(dc_norm(3,0:2*nres+2)) - allocate(dc_norm(3,0:2*nres+2)) - dc_norm(:,:)=0.d0 - endif - - call int_from_cart(.true.,.false.) - call sc_loc_geom(.false.) - do i=1,nres - thetaref(i)=theta(i) - phiref(i)=phi(i) - enddo -! do i=1,2*nres -! vbld_inv(i)=0.d0 -! vbld(i)=0.d0 -! enddo - - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo -! write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3),& -! vbld_inv(i+nres) - enddo -! call chainbuild -! Copy the coordinates to reference coordinates -! Splits to single chain if occurs - -! do i=1,2*nres -! do j=1,3 -! cref(j,i,cou)=c(j,i) -! enddo -! enddo -! - if(.not.allocated(cref)) allocate(cref(3,2*nres+2,maxperm)) !(3,maxres2+2,maxperm) - if(.not.allocated(chain_rep)) allocate(chain_rep(3,2*nres+2,maxsym)) !(3,maxres2+2,maxsym) - if(.not.allocated(tabperm)) allocate(tabperm(maxperm,maxsym)) !(maxperm,maxsym) -!----------------------------- - kkk=1 - lll=0 - cou=1 - do i=1,nres - lll=lll+1 -!c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) - if (i.gt.1) then - if ((itype(i-1).eq.ntyp1).and.(i.gt.2)) then - chain_length=lll-1 - kkk=kkk+1 -! write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) - lll=1 - endif - endif - do j=1,3 - cref(j,i,cou)=c(j,i) - cref(j,i+nres,cou)=c(j,i+nres) - if (i.le.nres) then - chain_rep(j,lll,kkk)=c(j,i) - chain_rep(j,lll+nres,kkk)=c(j,i+nres) - endif - enddo - enddo - write (iout,*) chain_length - if (chain_length.eq.0) chain_length=nres - do j=1,3 - chain_rep(j,chain_length,symetr)=chain_rep(j,chain_length,1) - chain_rep(j,chain_length+nres,symetr) & - =chain_rep(j,chain_length+nres,1) - enddo -! diagnostic -! write (iout,*) "spraw lancuchy",chain_length,symetr -! do i=1,4 -! do kkk=1,chain_length -! write (iout,*) itype(kkk),(chain_rep(j,kkk,i), j=1,3) -! enddo -! enddo -! enddiagnostic -! makes copy of chains - write (iout,*) "symetr", symetr - - if (symetr.gt.1) then - call permut(symetr) - nperm=1 - do i=1,symetr - nperm=nperm*i - enddo - do i=1,nperm - write(iout,*) (tabperm(i,kkk),kkk=1,4) - enddo - do i=1,nperm - cou=0 - do kkk=1,symetr - icha=tabperm(i,kkk) -! write (iout,*) i,icha - do lll=1,chain_length - cou=cou+1 - if (cou.le.nres) then - do j=1,3 - kupa=mod(lll,chain_length) - iprzes=(kkk-1)*chain_length+lll - if (kupa.eq.0) kupa=chain_length -! write (iout,*) "kupa", kupa - cref(j,iprzes,i)=chain_rep(j,kupa,icha) - cref(j,iprzes+nres,i)=chain_rep(j,kupa+nres,icha) - enddo - endif - enddo - enddo - enddo - endif -!-koniec robienia kopii -! diag - do kkk=1,nperm - write (iout,*) "nowa struktura", nperm - do i=1,nres - write (iout,110) restyp(itype(i)),i,cref(1,i,kkk),& - cref(2,i,kkk),& - cref(3,i,kkk),cref(1,nres+i,kkk),& - cref(2,nres+i,kkk),cref(3,nres+i,kkk) - enddo - 100 format (//' alpha-carbon coordinates ',& - ' centroid coordinates'/ & - ' ', 6X,'X',11X,'Y',11X,'Z', & - 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - - enddo -!c enddiag - do j=1,nbfrag - do i=1,4 - bfrag(i,j)=bfrag(i,j)-ishift - enddo - enddo - - do j=1,nhfrag - do i=1,2 - hfrag(i,j)=hfrag(i,j)-ishift - enddo - enddo - ishift_pdb=ishift - - return - end subroutine readpdb -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - subroutine read_control -! -! Read contorl data -! -! use geometry_data - use comm_machsw - use energy_data - use control_data - use compare_data - use MCM_data - use map_data - use csa_data - use MD_data - use MPI_data - use random, only: random_init -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MP - use prng, only:prng_restart - include 'mpif.h' - logical :: OKRandom!, prng_restart - real(kind=8) :: r1 -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.THREAD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.MCM' -! include 'COMMON.MAP' -! include 'COMMON.HEADER' -! include 'COMMON.CSA' -! include 'COMMON.CHAIN' -! include 'COMMON.MUCA' -! include 'COMMON.MD' -! include 'COMMON.FFIELD' -! include 'COMMON.INTERACT' -! include 'COMMON.SETUP' -!el integer :: KDIAG,ICORFL,IXDR -!el COMMON /MACHSW/ KDIAG,ICORFL,IXDR - character(len=8),dimension(0:3) :: diagmeth = reshape((/'Library ',& - 'EVVRSP ','Givens ','Jacobi '/),shape(diagmeth)) -! character(len=80) :: ucase - character(len=640) :: controlcard - - real(kind=8) :: seed,rmsdbc,rmsdbc1max,rmsdbcm,drms,timem!,& - - - nglob_csa=0 - eglob_csa=1d99 - nmin_csa=0 - read (INP,'(a)') titel - call card_concat(controlcard,.true.) -! out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0 -! print *,"Processor",me," fg_rank",fg_rank," out1file",out1file - call reada(controlcard,'SEED',seed,0.0D0) - call random_init(seed) -! Set up the time limit (caution! The time must be input in minutes!) - read_cart=index(controlcard,'READ_CART').gt.0 - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - call readi(controlcard,'SYM',symetr,1) - call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours - unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 - call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes - call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) - call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) - call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) - call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) - call reada(controlcard,'DRMS',drms,0.1D0) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then - write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc - write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 - write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max - write (iout,'(a,f10.1)')'DRMS = ',drms - write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm - write (iout,'(a,f10.1)') 'Time limit (min):',timlim - endif - call readi(controlcard,'NZ_START',nz_start,0) - call readi(controlcard,'NZ_END',nz_end,0) - call readi(controlcard,'IZ_SC',iz_sc,0) - timlim=60.0D0*timlim - safety = 60.0d0*safety - timem=timlim - modecalc=0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - minim=(index(controlcard,'MINIMIZE').gt.0) - dccart=(index(controlcard,'CART').gt.0) - overlapsc=(index(controlcard,'OVERLAP').gt.0) - overlapsc=.not.overlapsc - searchsc=(index(controlcard,'NOSEARCHSC').gt.0) - searchsc=.not.searchsc - sideadd=(index(controlcard,'SIDEADD').gt.0) - energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) - outpdb=(index(controlcard,'PDBOUT').gt.0) - outmol2=(index(controlcard,'MOL2OUT').gt.0) - pdbref=(index(controlcard,'PDBREF').gt.0) - refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0) - indpdb=index(controlcard,'PDBSTART') - extconf=(index(controlcard,'EXTCONF').gt.0) - call readi(controlcard,'IPRINT',iprint,0) - call readi(controlcard,'MAXGEN',maxgen,10000) - call readi(controlcard,'MAXOVERLAP',maxoverlap,1000) - call readi(controlcard,"KDIAG",kdiag,0) - call readi(controlcard,"RESCALE_MODE",rescale_mode,2) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) & - write (iout,*) "RESCALE_MODE",rescale_mode - split_ene=index(controlcard,'SPLIT_ENE').gt.0 - if (index(controlcard,'REGULAR').gt.0.0D0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - modecalc=1 - refstr=.true. - endif - if (index(controlcard,'CHECKGRAD').gt.0) then - modecalc=5 - if (index(controlcard,'CART').gt.0) then - icheckgrad=1 - elseif (index(controlcard,'CARINT').gt.0) then - icheckgrad=2 - else - icheckgrad=3 - endif - elseif (index(controlcard,'THREAD').gt.0) then - modecalc=2 - call readi(controlcard,'THREAD',nthread,0) - if (nthread.gt.0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - else - if (fg_rank.eq.0) & - write (iout,'(a)')'A number has to follow the THREAD keyword.' - stop 'Error termination in Read_Control.' - endif - else if (index(controlcard,'MCMA').gt.0) then - modecalc=3 - else if (index(controlcard,'MCEE').gt.0) then - modecalc=6 - else if (index(controlcard,'MULTCONF').gt.0) then - modecalc=4 - else if (index(controlcard,'MAP').gt.0) then - modecalc=7 - call readi(controlcard,'MAP',nmap,0) - else if (index(controlcard,'CSA').gt.0) then - modecalc=8 -!rc else if (index(controlcard,'ZSCORE').gt.0) then -!rc -!rc ZSCORE is rm from UNRES, modecalc=9 is available -!rc -!rc modecalc=9 -!fcm else if (index(controlcard,'MCMF').gt.0) then -!fmc modecalc=10 - else if (index(controlcard,'SOFTREG').gt.0) then - modecalc=11 - else if (index(controlcard,'CHECK_BOND').gt.0) then - modecalc=-1 - else if (index(controlcard,'TEST').gt.0) then - modecalc=-2 - else if (index(controlcard,'MD').gt.0) then - modecalc=12 - else if (index(controlcard,'RE ').gt.0) then - modecalc=14 - endif - - lmuca=index(controlcard,'MUCA').gt.0 - call readi(controlcard,'MUCADYN',mucadyn,0) - call readi(controlcard,'MUCASMOOTH',muca_smooth,0) - if (lmuca .and. (me.eq.king .or. .not.out1file )) & - then - write (iout,*) 'MUCADYN=',mucadyn - write (iout,*) 'MUCASMOOTH=',muca_smooth - endif - - iscode=index(controlcard,'ONE_LETTER') - indphi=index(controlcard,'PHI') - indback=index(controlcard,'BACK') - iranconf=index(controlcard,'RAND_CONF') - i2ndstr=index(controlcard,'USE_SEC_PRED') - gradout=index(controlcard,'GRADOUT').gt.0 - gnorm_check=index(controlcard,'GNORM_CHECK').gt.0 - call reada(controlcard,'DISTCHAINMAX',distchainmax,5.0d0) - if (me.eq.king .or. .not.out1file ) & - write (iout,*) "DISTCHAINMAX",distchainmax - - if(me.eq.king.or..not.out1file) & - write (iout,'(2a)') diagmeth(kdiag),& - ' routine used to diagonalize matrices.' - return - end subroutine read_control -!----------------------------------------------------------------------------- - subroutine read_REMDpar -! -! Read REMD settings -! -! use control -! use energy -! use geometry - use REMD_data - use MPI_data - use control_data, only:out1file -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.MD' - use MD_data -!el #ifndef LANG0 -!el include 'COMMON.LANGEVIN' -!el #else -!el include 'COMMON.LANGEVIN.lang0' -!el #endif -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.REMD' -! include 'COMMON.CONTROL' -! include 'COMMON.SETUP' -! character(len=80) :: ucase - character(len=320) :: controlcard - character(len=3200) :: controlcard1 - integer :: iremd_m_total -!el local variables - integer :: i -! real(kind=8) :: var,ene - - if(me.eq.king.or..not.out1file) & - write (iout,*) "REMD setup" - - call card_concat(controlcard,.true.) - call readi(controlcard,"NREP",nrep,3) - call readi(controlcard,"NSTEX",nstex,1000) - call reada(controlcard,"RETMIN",retmin,10.0d0) - call reada(controlcard,"RETMAX",retmax,1000.0d0) - mremdsync=(index(controlcard,'SYNC').gt.0) - call readi(controlcard,"NSYN",i_sync_step,100) - restart1file=(index(controlcard,'REST1FILE').gt.0) - traj1file=(index(controlcard,'TRAJ1FILE').gt.0) - call readi(controlcard,"TRAJCACHE",max_cache_traj_use,1) - if(max_cache_traj_use.gt.max_cache_traj) & - max_cache_traj_use=max_cache_traj - if(me.eq.king.or..not.out1file) then -!d if (traj1file) then -!rc caching is in testing - NTWX is not ignored -!d write (iout,*) "NTWX value is ignored" -!d write (iout,*) " trajectory is stored to one file by master" -!d write (iout,*) " before exchange at NSTEX intervals" -!d endif - write (iout,*) "NREP= ",nrep - write (iout,*) "NSTEX= ",nstex - write (iout,*) "SYNC= ",mremdsync - write (iout,*) "NSYN= ",i_sync_step - write (iout,*) "TRAJCACHE= ",max_cache_traj_use - endif - remd_tlist=.false. - allocate(remd_t(nrep),remd_m(nrep)) !(maxprocs) - if (index(controlcard,'TLIST').gt.0) then - remd_tlist=.true. - call card_concat(controlcard1,.true.) - read(controlcard1,*) (remd_t(i),i=1,nrep) - if(me.eq.king.or..not.out1file) & - write (iout,*)'tlist',(remd_t(i),i=1,nrep) - endif - remd_mlist=.false. - if (index(controlcard,'MLIST').gt.0) then - remd_mlist=.true. - call card_concat(controlcard1,.true.) - read(controlcard1,*) (remd_m(i),i=1,nrep) - if(me.eq.king.or..not.out1file) then - write (iout,*)'mlist',(remd_m(i),i=1,nrep) - iremd_m_total=0 - do i=1,nrep - iremd_m_total=iremd_m_total+remd_m(i) - enddo - write (iout,*) 'Total number of replicas ',iremd_m_total - endif - endif - if(me.eq.king.or..not.out1file) & - write (iout,'(/30(1h=),a,29(1h=)/)') " End of REMD run setup " - return - end subroutine read_REMDpar -!----------------------------------------------------------------------------- - subroutine read_MDpar -! -! Read MD settings -! - use control_data, only: r_cut,rlamb,out1file - use energy_data - use geometry_data, only: pi - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.MD' - use MD_data -!el #ifndef LANG0 -!el include 'COMMON.LANGEVIN' -!el #else -!el include 'COMMON.LANGEVIN.lang0' -!el #endif -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.SETUP' -! include 'COMMON.CONTROL' -! include 'COMMON.SPLITELE' -! character(len=80) :: ucase - character(len=320) :: controlcard -!el local variables - integer :: i - real(kind=8) :: eta - - call card_concat(controlcard,.true.) - call readi(controlcard,"NSTEP",n_timestep,1000000) - call readi(controlcard,"NTWE",ntwe,100) - call readi(controlcard,"NTWX",ntwx,1000) - call reada(controlcard,"DT",d_time,1.0d-1) - call reada(controlcard,"DVMAX",dvmax,2.0d1) - call reada(controlcard,"DAMAX",damax,1.0d1) - call reada(controlcard,"EDRIFTMAX",edriftmax,1.0d+1) - call readi(controlcard,"LANG",lang,0) - RESPA = index(controlcard,"RESPA") .gt. 0 - call readi(controlcard,"NTIME_SPLIT",ntime_split,1) - ntime_split0=ntime_split - call readi(controlcard,"MAXTIME_SPLIT",maxtime_split,64) - ntime_split0=ntime_split - call reada(controlcard,"R_CUT",r_cut,2.0d0) - call reada(controlcard,"LAMBDA",rlamb,0.3d0) - rest = index(controlcard,"REST").gt.0 - tbf = index(controlcard,"TBF").gt.0 - usampl = index(controlcard,"USAMPL").gt.0 - mdpdb = index(controlcard,"MDPDB").gt.0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - call reada(controlcard,"TAU_BATH",tau_bath,1.0d-1) - call reada(controlcard,"EQ_TIME",eq_time,1.0d+4) - call readi(controlcard,"RESET_MOMENT",count_reset_moment,1000) - if (count_reset_moment.eq.0) count_reset_moment=1000000000 - call readi(controlcard,"RESET_VEL",count_reset_vel,1000) - reset_moment=lang.eq.0 .and. tbf .and. count_reset_moment.gt.0 - reset_vel=lang.eq.0 .and. tbf .and. count_reset_vel.gt.0 - if (count_reset_vel.eq.0) count_reset_vel=1000000000 - large = index(controlcard,"LARGE").gt.0 - print_compon = index(controlcard,"PRINT_COMPON").gt.0 - rattle = index(controlcard,"RATTLE").gt.0 -! if performing umbrella sampling, fragments constrained are read from the fragment file - nset=0 - if(usampl) then - call read_fragments - endif - - if(me.eq.king.or..not.out1file) then - write (iout,*) - write (iout,'(27(1h=),a26,27(1h=))') " Parameters of the MD run " - write (iout,*) - write (iout,'(a)') "The units are:" - write (iout,'(a)') "positions: angstrom, time: 48.9 fs" - write (iout,'(2a)') "velocity: angstrom/(48.9 fs),",& - " acceleration: angstrom/(48.9 fs)**2" - write (iout,'(a)') "energy: kcal/mol, temperature: K" - write (iout,*) - write (iout,'(a60,i10)') "Number of time steps:",n_timestep - write (iout,'(a60,f10.5,a)') & - "Initial time step of numerical integration:",d_time,& - " natural units" - write (iout,'(60x,f10.5,a)') d_time*48.9," fs" - if (RESPA) then - write (iout,'(2a,i4,a)') & - "A-MTS algorithm used; initial time step for fast-varying",& - " short-range forces split into",ntime_split," steps." - write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff",& - r_cut," lambda",rlamb - endif - write (iout,'(2a,f10.5)') & - "Maximum acceleration threshold to reduce the time step",& - "/increase split number:",damax - write (iout,'(2a,f10.5)') & - "Maximum predicted energy drift to reduce the timestep",& - "/increase split number:",edriftmax - write (iout,'(a60,f10.5)') & - "Maximum velocity threshold to reduce velocities:",dvmax - write (iout,'(a60,i10)') "Frequency of property output:",ntwe - write (iout,'(a60,i10)') "Frequency of coordinate output:",ntwx - if (rattle) write (iout,'(a60)') & - "Rattle algorithm used to constrain the virtual bonds" - endif - reset_fricmat=1000 - if (lang.gt.0) then - call reada(controlcard,"ETAWAT",etawat,0.8904d0) - call reada(controlcard,"RWAT",rwat,1.4d0) - call reada(controlcard,"SCAL_FRIC",scal_fric,2.0d-2) - surfarea=index(controlcard,"SURFAREA").gt.0 - call readi(controlcard,"RESET_FRICMAT",reset_fricmat,1000) - if(me.eq.king.or..not.out1file)then - write (iout,'(/a,$)') "Langevin dynamics calculation" - if (lang.eq.1) then - write (iout,'(a/)') & - " with direct integration of Langevin equations" - else if (lang.eq.2) then - write (iout,'(a/)') " with TINKER stochasic MD integrator" - else if (lang.eq.3) then - write (iout,'(a/)') " with Ciccotti's stochasic MD integrator" - else if (lang.eq.4) then - write (iout,'(a/)') " in overdamped mode" - else - write (iout,'(//a,i5)') & - "=========== ERROR: Unknown Langevin dynamics mode:",lang - stop - endif - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Viscosity of the solvent:",etawat - write (iout,'(a60,f10.5)') "Radius of solvent molecule:",rwat - write (iout,'(a60,f10.5)') & - "Scaling factor of the friction forces:",scal_fric - if (surfarea) write (iout,'(2a,i10,a)') & - "Friction coefficients will be scaled by solvent-accessible",& - " surface area every",reset_fricmat," steps." - endif -! Calculate friction coefficients and bounds of stochastic forces - eta=6*pi*cPoise*etawat - if(me.eq.king.or..not.out1file) & - write(iout,'(a60,f10.5)')"Eta of the solvent in natural units:",& - eta - gamp=scal_fric*(pstok+rwat)*eta - stdfp=dsqrt(2*Rb*t_bath/d_time) - allocate(gamsc(ntyp1),stdfsc(ntyp1)) !(ntyp1) - do i=1,ntyp - gamsc(i)=scal_fric*(restok(i)+rwat)*eta - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - if(me.eq.king.or..not.out1file)then - write (iout,'(/2a/)') & - "Radii of site types and friction coefficients and std's of",& - " stochastic forces of fully exposed sites" - write (iout,'(a5,f5.2,2f10.5)')'p',pstok,gamp,stdfp*dsqrt(gamp) - do i=1,ntyp - write (iout,'(a5,f5.2,2f10.5)') restyp(i),restok(i),& - gamsc(i),stdfsc(i)*dsqrt(gamsc(i)) - enddo - endif - else if (tbf) then - if(me.eq.king.or..not.out1file)then - write (iout,'(a)') "Berendsen bath calculation" - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Coupling constant (tau):",tau_bath - if (reset_moment) & - write (iout,'(a,i10,a)') "Momenta will be reset at zero every",& - count_reset_moment," steps" - if (reset_vel) & - write (iout,'(a,i10,a)') & - "Velocities will be reset at random every",count_reset_vel,& - " steps" - endif - else - if(me.eq.king.or..not.out1file) & - write (iout,'(a31)') "Microcanonical mode calculation" - endif - if(me.eq.king.or..not.out1file)then - if (rest) write (iout,'(/a/)') "===== Calculation restarted ====" - if (usampl) then - write(iout,*) "MD running with constraints." - write(iout,*) "Equilibration time ", eq_time, " mtus." - write(iout,*) "Constraining ", nfrag," fragments." - write(iout,*) "Length of each fragment, weight and q0:" - do iset=1,nset - write (iout,*) "Set of restraints #",iset - do i=1,nfrag - write(iout,'(2i5,f8.1,f7.4)') ifrag(1,i,iset),& - ifrag(2,i,iset),wfrag(i,iset),qinfrag(i,iset) - enddo - write(iout,*) "constraints between ", npair, "fragments." - write(iout,*) "constraint pairs, weights and q0:" - do i=1,npair - write(iout,'(2i5,f8.1,f7.4)') ipair(1,i,iset),& - ipair(2,i,iset),wpair(i,iset),qinpair(i,iset) - enddo - write(iout,*) "angle constraints within ", nfrag_back,& - "backbone fragments." - write(iout,*) "fragment, weights:" - do i=1,nfrag_back - write(iout,'(2i5,3f8.1)') ifrag_back(1,i,iset),& - ifrag_back(2,i,iset),wfrag_back(1,i,iset),& - wfrag_back(2,i,iset),wfrag_back(3,i,iset) - enddo - enddo - iset=mod(kolor,nset)+1 - endif - endif - if(me.eq.king.or..not.out1file) & - write (iout,'(/30(1h=),a,29(1h=)/)') " End of MD run setup " - return - end subroutine read_MDpar -!----------------------------------------------------------------------------- - subroutine map_read - - use map_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MAP' -! include 'COMMON.IOUNITS' - character(len=3) :: angid(4) = (/'THE','PHI','ALP','OME'/) - character(len=80) :: mapcard !,ucase -!el local variables - integer :: imap -! real(kind=8) :: var,ene - - do imap=1,nmap - read (inp,'(a)') mapcard - mapcard=ucase(mapcard) - if (index(mapcard,'PHI').gt.0) then - kang(imap)=1 - else if (index(mapcard,'THE').gt.0) then - kang(imap)=2 - else if (index(mapcard,'ALP').gt.0) then - kang(imap)=3 - else if (index(mapcard,'OME').gt.0) then - kang(imap)=4 - else - write(iout,'(a)')'Error - illegal variable spec in MAP card.' - stop 'Error - illegal variable spec in MAP card.' - endif - call readi (mapcard,'RES1',res1(imap),0) - call readi (mapcard,'RES2',res2(imap),0) - if (res1(imap).eq.0) then - res1(imap)=res2(imap) - else if (res2(imap).eq.0) then - res2(imap)=res1(imap) - endif - if(res1(imap)*res2(imap).eq.0 .or. res1(imap).gt.res2(imap))then - write (iout,'(a)') & - 'Error - illegal definition of variable group in MAP.' - stop 'Error - illegal definition of variable group in MAP.' - endif - call reada(mapcard,'FROM',ang_from(imap),0.0D0) - call reada(mapcard,'TO',ang_to(imap),0.0D0) - call readi(mapcard,'NSTEP',nstep(imap),0) - if (ang_from(imap).eq.ang_to(imap) .or. nstep(imap).eq.0) then - write (iout,'(a)') & - 'Illegal boundary and/or step size specification in MAP.' - stop 'Illegal boundary and/or step size specification in MAP.' - endif - enddo ! imap - return - end subroutine map_read -!----------------------------------------------------------------------------- - subroutine csaread - - use control_data, only: vdisulf - use csa_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.CONTROL' -! character(len=80) :: ucase - character(len=620) :: mcmcard -!el local variables -! integer :: ntf,ik,iw_pdb -! real(kind=8) :: var,ene - - call card_concat(mcmcard,.true.) - - call readi(mcmcard,'NCONF',nconf,50) - call readi(mcmcard,'NADD',nadd,0) - call readi(mcmcard,'JSTART',jstart,1) - call readi(mcmcard,'JEND',jend,1) - call readi(mcmcard,'NSTMAX',nstmax,500000) - call readi(mcmcard,'N0',n0,1) - call readi(mcmcard,'N1',n1,6) - call readi(mcmcard,'N2',n2,4) - call readi(mcmcard,'N3',n3,0) - call readi(mcmcard,'N4',n4,0) - call readi(mcmcard,'N5',n5,0) - call readi(mcmcard,'N6',n6,10) - call readi(mcmcard,'N7',n7,0) - call readi(mcmcard,'N8',n8,0) - call readi(mcmcard,'N9',n9,0) - call readi(mcmcard,'N14',n14,0) - call readi(mcmcard,'N15',n15,0) - call readi(mcmcard,'N16',n16,0) - call readi(mcmcard,'N17',n17,0) - call readi(mcmcard,'N18',n18,0) - - vdisulf=(index(mcmcard,'DYNSS').gt.0) - - call readi(mcmcard,'NDIFF',ndiff,2) - call reada(mcmcard,'DIFFCUT',diffcut,0.0d0) - call readi(mcmcard,'IS1',is1,1) - call readi(mcmcard,'IS2',is2,8) - call readi(mcmcard,'NRAN0',nran0,4) - call readi(mcmcard,'NRAN1',nran1,2) - call readi(mcmcard,'IRR',irr,1) - call readi(mcmcard,'NSEED',nseed,20) - call readi(mcmcard,'NTOTAL',ntotal,10000) - call reada(mcmcard,'CUT1',cut1,2.0d0) - call reada(mcmcard,'CUT2',cut2,5.0d0) - call reada(mcmcard,'ESTOP',estop,-3000.0d0) - call readi(mcmcard,'ICMAX',icmax,3) - call readi(mcmcard,'IRESTART',irestart,0) -!!bankt call readi(mcmcard,'NBANKTM',ntbankm,0) - ntbankm=0 -!!bankt - call reada(mcmcard,'DELE',dele,20.0d0) - call reada(mcmcard,'DIFCUT',difcut,720.0d0) - call readi(mcmcard,'IREF',iref,0) - call reada(mcmcard,'RMSCUT',rmscut,4.0d0) - call reada(mcmcard,'PNCCUT',pnccut,0.5d0) - call readi(mcmcard,'NCONF_IN',nconf_in,0) - call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) - write (iout,*) "NCONF_IN",nconf_in - return - end subroutine csaread -!----------------------------------------------------------------------------- - subroutine mcmread - - use mcm_data - use control_data, only: MaxMoveType - use MD_data - use minim_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MCM' -! include 'COMMON.MCE' -! include 'COMMON.IOUNITS' -! character(len=80) :: ucase - character(len=320) :: mcmcard -!el local variables - integer :: i -! real(kind=8) :: var,ene - - call card_concat(mcmcard,.true.) - call readi(mcmcard,'MAXACC',maxacc,100) - call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000) - call readi(mcmcard,'MAXTRIAL',maxtrial,100) - call readi(mcmcard,'MAXTRIAL_ITER',maxtrial_iter,1000) - call readi(mcmcard,'MAXREPM',maxrepm,200) - call reada(mcmcard,'RANFRACT',RanFract,0.5D0) - call reada(mcmcard,'POOL_FRACT',pool_fraction,0.01D0) - call reada(mcmcard,'OVERLAP',overlap_cut,1.0D3) - call reada(mcmcard,'E_UP',e_up,5.0D0) - call reada(mcmcard,'DELTE',delte,0.1D0) - call readi(mcmcard,'NSWEEP',nsweep,5) - call readi(mcmcard,'NSTEPH',nsteph,0) - call readi(mcmcard,'NSTEPC',nstepc,0) - call reada(mcmcard,'TMIN',tmin,298.0D0) - call reada(mcmcard,'TMAX',tmax,298.0D0) - call readi(mcmcard,'NWINDOW',nwindow,0) - call readi(mcmcard,'PRINT_MC',print_mc,0) - print_stat=(index(mcmcard,'NO_PRINT_STAT').le.0) - print_int=(index(mcmcard,'NO_PRINT_INT').le.0) - ent_read=(index(mcmcard,'ENT_READ').gt.0) - call readi(mcmcard,'SAVE_FREQ',save_frequency,1000) - call readi(mcmcard,'MESSAGE_FREQ',message_frequency,1000) - call readi(mcmcard,'POOL_READ_FREQ',pool_read_freq,5000) - call readi(mcmcard,'POOL_SAVE_FREQ',pool_save_freq,1000) - call readi(mcmcard,'PRINT_FREQ',print_freq,1000) - if (nwindow.gt.0) then - allocate(winstart(nwindow)) !!el (maxres) - allocate(winend(nwindow)) !!el - allocate(winlen(nwindow)) !!el - read (inp,*) (winstart(i),winend(i),i=1,nwindow) - do i=1,nwindow - winlen(i)=winend(i)-winstart(i)+1 - enddo - endif - if (tmax.lt.tmin) tmax=tmin - if (tmax.eq.tmin) then - nstepc=0 - nsteph=0 - endif - if (nstepc.gt.0 .and. nsteph.gt.0) then - tsteph=(tmax/tmin)**(1.0D0/(nsteph+0.0D0)) - tstepc=(tmax/tmin)**(1.0D0/(nstepc+0.0D0)) - endif - allocate(sumpro_type(0:MaxMoveType)) !(0:MaxMoveType) -! Probabilities of different move types - sumpro_type(0)=0.0D0 - call reada(mcmcard,'MULTI_BOND',sumpro_type(1),1.0d0) - call reada(mcmcard,'ONE_ANGLE' ,sumpro_type(2),2.0d0) - sumpro_type(2)=sumpro_type(1)+sumpro_type(2) - call reada(mcmcard,'THETA' ,sumpro_type(3),0.0d0) - sumpro_type(3)=sumpro_type(2)+sumpro_type(3) - call reada(mcmcard,'SIDE_CHAIN',sumpro_type(4),0.5d0) - sumpro_type(4)=sumpro_type(3)+sumpro_type(4) - do i=1,MaxMoveType - print *,'i',i,' sumprotype',sumpro_type(i) - sumpro_type(i)=sumpro_type(i)/sumpro_type(MaxMoveType) - print *,'i',i,' sumprotype',sumpro_type(i) - enddo - return - end subroutine mcmread -!----------------------------------------------------------------------------- - subroutine read_minim - - use minim_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MINIM' -! include 'COMMON.IOUNITS' -! character(len=80) :: ucase - character(len=320) :: minimcard -!el local variables -! integer :: ntf,ik,iw_pdb -! real(kind=8) :: var,ene - - call card_concat(minimcard,.true.) - call readi(minimcard,'MAXMIN',maxmin,2000) - call readi(minimcard,'MAXFUN',maxfun,5000) - call readi(minimcard,'MINMIN',minmin,maxmin) - call readi(minimcard,'MINFUN',minfun,maxmin) - call reada(minimcard,'TOLF',tolf,1.0D-2) - call reada(minimcard,'RTOLF',rtolf,1.0D-4) - print_min_stat=min0(index(minimcard,'PRINT_MIN_STAT'),1) - print_min_res=min0(index(minimcard,'PRINT_MIN_RES'),1) - print_min_ini=min0(index(minimcard,'PRINT_MIN_INI'),1) - write (iout,'(/80(1h*)/20x,a/80(1h*))') & - 'Options in energy minimization:' - write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)') & - 'MaxMin:',MaxMin,' MaxFun:',MaxFun,& - 'MinMin:',MinMin,' MinFun:',MinFun,& - ' TolF:',TolF,' RTolF:',RTolF - return - end subroutine read_minim -!----------------------------------------------------------------------------- - subroutine openunits - - use energy_data, only: usampl - use csa_data - use MPI_data - use control_data, only:out1file - use control, only: getenv_loc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - character(len=16) :: form,nodename - integer :: nodelen,ierror,npos -#endif -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' -! include 'COMMON.MD' -! include 'COMMON.CONTROL' - integer :: lenpre,lenpot,lentmp !,ilen -!el external ilen - character(len=3) :: out1file_text !,ucase - character(len=3) :: ll -!el external ucase -!el local variables -! integer :: ntf,ik,iw_pdb -! real(kind=8) :: var,ene -! -! print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits" - call getenv_loc("PREFIX",prefix) - pref_orig = prefix - call getenv_loc("POT",pot) - call getenv_loc("DIRTMP",tmpdir) - call getenv_loc("CURDIR",curdir) - call getenv_loc("OUT1FILE",out1file_text) -! print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV" - out1file_text=ucase(out1file_text) - if (out1file_text(1:1).eq."Y") then - out1file=.true. - else - out1file=fg_rank.gt.0 - endif - lenpre=ilen(prefix) - lenpot=ilen(pot) - lentmp=ilen(tmpdir) - if (lentmp.gt.0) then - write (*,'(80(1h!))') - write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!" - write (*,'(80(1h!))') - write (*,*)"All output files will be on node /tmp directory." -#ifdef MPI - call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR ) - if (me.eq.king) then - write (*,*) "The master node is ",nodename - else if (fg_rank.eq.0) then - write (*,*) "I am the CG slave node ",nodename - else - write (*,*) "I am the FG slave node ",nodename - endif -#endif - PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre) - lenpre = lentmp+lenpre+1 - endif - entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' -! Get the names and open the input files -#if defined(WINIFL) || defined(WINPGI) - open(1,file=pref_orig(:ilen(pref_orig))// & - '.inp',status='old',readonly,shared) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -! Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',readonly,shared) - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',readonly,shared) - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',readonly,shared) - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',readonly,shared) - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',readonly,shared) - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly,shared) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly,shared) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old',& - action='read') -! print *,"Processor",myrank," opened file 1" - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -! print *,"Processor",myrank," opened file 9" -! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -! Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',action='read') -! print *,"Processor",myrank," opened file IBOND" - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',action='read') -! print *,"Processor",myrank," opened file ITHEP" - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',action='read') -! print *,"Processor",myrank," opened file IROTAM" - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',action='read') -! print *,"Processor",myrank," opened file ITORP" - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',action='read') -! print *,"Processor",myrank," opened file ITORDP" - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',action='read') -! print *,"Processor",myrank," opened file ISCCOR" - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',action='read') -! print *,"Processor",myrank," opened file IFOURIER" - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',action='read') -! print *,"Processor",myrank," opened file IELEP" - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',action='read') -! print *,"Processor",myrank," opened file ISIDEP" -! print *,"Processor",myrank," opened parameter files" -#elif (defined G77) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old') - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -! Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old') - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old') - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old') - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old') - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old') - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') -#else - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old',& - readonly) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -! open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -! Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',action='read') - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',action='read') - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',action='read') - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',action='read') - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',action='read') - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',action='read') -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - print *,"thetname_pdb ",thetname_pdb - open (ithep_pdb,file=thetname_pdb,status='old',action='read') - print *,ithep_pdb," opened" -#endif - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly) -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',action='read') -#endif -#endif -#ifndef OLDSCP -! -! 8/9/01 In the newest version SCp interaction constants are read from a file -! Use -DOLDSCP to use hard-coded constants instead. -! - call getenv_loc('SCPPAR',scpname) -#if defined(WINIFL) || defined(WINPGI) - open (iscpp,file=scpname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (iscpp,file=scpname,status='old',action='read') -#elif (defined G77) - open (iscpp,file=scpname,status='old') -#else - open (iscpp,file=scpname,status='old',action='read') -#endif -#endif - call getenv_loc('PATTERN',patname) -#if defined(WINIFL) || defined(WINPGI) - open (icbase,file=patname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (icbase,file=patname,status='old',action='read') -#elif (defined G77) - open (icbase,file=patname,status='old') -#else - open (icbase,file=patname,status='old',action='read') -#endif -#ifdef MPI -! Open output file only for CG processes -! print *,"Processor",myrank," fg_rank",fg_rank - if (fg_rank.eq.0) then - - if (nodes.eq.1) then - npos=3 - else - npos = dlog10(dfloat(nodes-1))+1 - endif - if (npos.lt.3) npos=3 - write (liczba,'(i1)') npos - form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba)) & - //')' - write (liczba,form) me - outname=prefix(:lenpre)//'.out_'//pot(:lenpot)// & - liczba(:ilen(liczba)) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) & - //'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) & - //'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)// & - liczba(:ilen(liczba))//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)// & - liczba(:ilen(liczba))//'.stat' - if (lentmp.gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) & - //liczba(:ilen(liczba))//'.stat') - rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba)) & - //'.rst' - if(usampl) then - qname=prefix(:lenpre)//'_'//pot(:lenpot)// & - liczba(:ilen(liczba))//'.const' - endif - - endif -#else - outname=prefix(:lenpre)//'.out_'//pot(:lenpot) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat' - if (lentmp.gt.0) & - call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot)// & - '.stat') - rest2name=prefix(:ilen(prefix))//'.rst' - if(usampl) then - qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' - endif -#endif -#if defined(AIX) || defined(PGI) - if (me.eq.king .or. .not. out1file) & - open(iout,file=outname,status='unknown') -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll,& - status='unknown') - endif -#endif - if(me.eq.king) then - open(igeom,file=intname,status='unknown',position='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',position='append') - else -!1out open(iout,file=outname,status='unknown') - endif -#else - if (me.eq.king .or. .not.out1file) & - open(iout,file=outname,status='unknown') -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll,& - status='unknown') - endif -#endif - if(me.eq.king) then - open(igeom,file=intname,status='unknown',access='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',access='append') - else -!1out open(iout,file=outname,status='unknown') - endif -#endif - csa_rbank=prefix(:lenpre)//'.CSA.rbank' - csa_seed=prefix(:lenpre)//'.CSA.seed' - csa_history=prefix(:lenpre)//'.CSA.history' - csa_bank=prefix(:lenpre)//'.CSA.bank' - csa_bank1=prefix(:lenpre)//'.CSA.bank1' - csa_alpha=prefix(:lenpre)//'.CSA.alpha' - csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' -!!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' - csa_int=prefix(:lenpre)//'.int' - csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' - csa_native_int=prefix(:lenpre)//'.CSA.native.int' - csa_in=prefix(:lenpre)//'.CSA.in' -! print *,"Processor",myrank,"fg_rank",fg_rank," opened files" -! Write file names - if (me.eq.king)then - write (iout,'(80(1h-))') - write (iout,'(30x,a)') "FILE ASSIGNMENT" - write (iout,'(80(1h-))') - write (iout,*) "Input file : ",& - pref_orig(:ilen(pref_orig))//'.inp' - write (iout,*) "Output file : ",& - outname(:ilen(outname)) - write (iout,*) - write (iout,*) "Sidechain potential file : ",& - sidename(:ilen(sidename)) -#ifndef OLDSCP - write (iout,*) "SCp potential file : ",& - scpname(:ilen(scpname)) -#endif - write (iout,*) "Electrostatic potential file : ",& - elename(:ilen(elename)) - write (iout,*) "Cumulant coefficient file : ",& - fouriername(:ilen(fouriername)) - write (iout,*) "Torsional parameter file : ",& - torname(:ilen(torname)) - write (iout,*) "Double torsional parameter file : ",& - tordname(:ilen(tordname)) - write (iout,*) "SCCOR parameter file : ",& - sccorname(:ilen(sccorname)) - write (iout,*) "Bond & inertia constant file : ",& - bondname(:ilen(bondname)) - write (iout,*) "Bending parameter file : ",& - thetname(:ilen(thetname)) - write (iout,*) "Rotamer parameter file : ",& - rotname(:ilen(rotname)) -!el---- -#ifndef CRYST_THETA - write (iout,*) "Thetpdb parameter file : ",& - thetname_pdb(:ilen(thetname_pdb)) -#endif -!el - write (iout,*) "Threading database : ",& - patname(:ilen(patname)) - if (lentmp.ne.0) & - write (iout,*)" DIRTMP : ",& - tmpdir(:lentmp) - write (iout,'(80(1h-))') - endif - return - end subroutine openunits -!----------------------------------------------------------------------------- - subroutine readrst - - use geometry_data, only: nres,dc - use energy_data, only: usampl,iset - use MD_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.MD' -!el local variables - integer ::i,j -! real(kind=8) :: var,ene - - open(irest2,file=rest2name,status='unknown') - read(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - read(irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - read(irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl) then - read (irest2,*) iset - endif - close(irest2) - return - end subroutine readrst -!----------------------------------------------------------------------------- - subroutine read_fragments - - use energy_data -! use geometry - use control_data, only:out1file - use MD_data - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.MD' -! include 'COMMON.CONTROL' -!el local variables - integer :: i -! real(kind=8) :: var,ene - - read(inp,*) nset,nfrag,npair,nfrag_back - -!el from module energy -! if(.not.allocated(mset)) allocate(mset(nset)) !(maxprocs/20) - if(.not.allocated(wfrag_back)) then - allocate(wfrag_back(3,nfrag_back,nset)) !(3,maxfrag_back,maxprocs/20) - allocate(ifrag_back(3,nfrag_back,nset)) !(3,maxfrag_back,maxprocs/20) - - allocate(qinfrag(nfrag,nset),wfrag(nfrag,nset)) !(50,maxprocs/20) - allocate(ifrag(2,nfrag,nset)) !(2,50,maxprocs/20) - - allocate(qinpair(npair,nset),wpair(npair,nset)) !(100,maxprocs/20) - allocate(ipair(2,npair,nset)) !(2,100,maxprocs/20) - endif - - if(me.eq.king.or..not.out1file) & - write(iout,*) "nset",nset," nfrag",nfrag," npair",npair,& - " nfrag_back",nfrag_back - do iset=1,nset - read(inp,*) mset(iset) - do i=1,nfrag - read(inp,*) wfrag(i,iset),ifrag(1,i,iset),ifrag(2,i,iset),& - qinfrag(i,iset) - if(me.eq.king.or..not.out1file) & - write(iout,*) "R ",i,wfrag(i,iset),ifrag(1,i,iset),& - ifrag(2,i,iset), qinfrag(i,iset) - enddo - do i=1,npair - read(inp,*) wpair(i,iset),ipair(1,i,iset),ipair(2,i,iset),& - qinpair(i,iset) - if(me.eq.king.or..not.out1file) & - write(iout,*) "R ",i,wpair(i,iset),ipair(1,i,iset),& - ipair(2,i,iset), qinpair(i,iset) - enddo - do i=1,nfrag_back - read(inp,*) wfrag_back(1,i,iset),wfrag_back(2,i,iset),& - wfrag_back(3,i,iset),& - ifrag_back(1,i,iset),ifrag_back(2,i,iset) - if(me.eq.king.or..not.out1file) & - write(iout,*) "A",i,wfrag_back(1,i,iset),wfrag_back(2,i,iset),& - wfrag_back(3,i,iset),ifrag_back(1,i,iset),ifrag_back(2,i,iset) - enddo - enddo - return - end subroutine read_fragments -!----------------------------------------------------------------------------- -! shift.F io_csa -!----------------------------------------------------------------------------- - subroutine csa_read - - use csa_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.IOUNITS' -!el local variables -! integer :: ntf,ik,iw_pdb -! real(kind=8) :: var,ene - - open(icsa_in,file=csa_in,status="old",err=100) - read(icsa_in,*) nconf - read(icsa_in,*) jstart,jend - read(icsa_in,*) nstmax - read(icsa_in,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - read(icsa_in,*) nran0,nran1,irr - read(icsa_in,*) nseed - read(icsa_in,*) ntotal,cut1,cut2 - read(icsa_in,*) estop - read(icsa_in,*) icmax,irestart - read(icsa_in,*) ntbankm,dele,difcut - read(icsa_in,*) iref,rmscut,pnccut - read(icsa_in,*) ndiff - close(icsa_in) - - return - - 100 continue - return - end subroutine csa_read -!----------------------------------------------------------------------------- - subroutine initial_write - - use csa_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -! include 'COMMON.IOUNITS' -!el local variables -! integer :: ntf,ik,iw_pdb -! real(kind=8) :: var,ene - - open(icsa_seed,file=csa_seed,status="unknown") - write(icsa_seed,*) "seed" - close(31) -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,status="unknown",& - position="append") -#else - open(icsa_history,file=csa_history,status="unknown",& - access="append") -#endif - write(icsa_history,*) nconf - write(icsa_history,*) jstart,jend - write(icsa_history,*) nstmax - write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - write(icsa_history,*) nran0,nran1,irr - write(icsa_history,*) nseed - write(icsa_history,*) ntotal,cut1,cut2 - write(icsa_history,*) estop - write(icsa_history,*) icmax,irestart - write(icsa_history,*) ntbankm,dele,difcut - write(icsa_history,*) iref,rmscut,pnccut - write(icsa_history,*) ndiff - - write(icsa_history,*) - close(icsa_history) - - open(icsa_bank1,file=csa_bank1,status="unknown") - write(icsa_bank1,*) 0 - close(icsa_bank1) - - return - end subroutine initial_write -!----------------------------------------------------------------------------- - subroutine restart_write - - use csa_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CSA' -! include 'COMMON.BANK' -!el local variables -! integer :: ntf,ik,iw_pdb -! real(kind=8) :: var,ene - -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,position="append") -#else - open(icsa_history,file=csa_history,access="append") -#endif - write(icsa_history,*) - write(icsa_history,*) "This is restart" - write(icsa_history,*) - write(icsa_history,*) nconf - write(icsa_history,*) jstart,jend - write(icsa_history,*) nstmax - write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - write(icsa_history,*) nran0,nran1,irr - write(icsa_history,*) nseed - write(icsa_history,*) ntotal,cut1,cut2 - write(icsa_history,*) estop - write(icsa_history,*) icmax,irestart - write(icsa_history,*) ntbankm,dele,difcut - write(icsa_history,*) iref,rmscut,pnccut - write(icsa_history,*) ndiff - write(icsa_history,*) - write(icsa_history,*) "irestart is: ", irestart - - write(icsa_history,*) - close(icsa_history) - - return - end subroutine restart_write -!----------------------------------------------------------------------------- -! test.F -!----------------------------------------------------------------------------- - subroutine write_pdb(npdb,titelloc,ee) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - character(len=50) :: titelloc1 - character*(*) :: titelloc - character(len=3) :: zahl - character(len=5) :: liczba5 - real(kind=8) :: ee - integer :: npdb !,ilen -!el external ilen -!el local variables - integer :: lenpre -! real(kind=8) :: var,ene - - titelloc1=titelloc - lenpre=ilen(prefix) - if (npdb.lt.1000) then - call numstr(npdb,zahl) - open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') - else - if (npdb.lt.10000) then - write(liczba5,'(i1,i4)') 0,npdb - else - write(liczba5,'(i5)') npdb - endif - open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') - endif - call pdbout(ee,titelloc1,ipdb) - close(ipdb) - return - end subroutine write_pdb -!----------------------------------------------------------------------------- -! thread.F -!----------------------------------------------------------------------------- - subroutine write_thread_summary -! Thread the sequence through a database of known structures - use control_data, only: refstr -! use geometry - use energy_data, only: n_ene_comp - use compare_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - use MPI_data !include 'COMMON.INFO' - include 'mpif.h' -#endif -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.DBASE' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.THREAD' -! include 'COMMON.FFIELD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.HEADER' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' - - integer,dimension(maxthread) :: ip - real(kind=8),dimension(0:n_ene) :: energia -!el local variables - integer :: i,j,ii,jj,ipj,ik,kk,ist - real(kind=8) :: enet,etot,rmsnat,rms,frac,frac_nn - - write (iout,'(30x,a/)') & - ' *********** Summary threading statistics ************' - write (iout,'(a)') 'Initial energies:' - write (iout,'(a4,2x,a12,14a14,3a8)') & - 'No','seq',(ename(print_order(i)),i=1,nprint_ene),'ETOT',& - 'RMSnat','NatCONT','NNCONT','RMS' -! Energy sort patterns - do i=1,nthread - ip(i)=i - enddo - do i=1,nthread-1 - enet=ener(n_ene-1,ip(i)) - jj=i - do j=i+1,nthread - if (ener(n_ene-1,ip(j)).lt.enet) then - jj=j - enet=ener(n_ene-1,ip(j)) - endif - enddo - if (jj.ne.i) then - ipj=ip(jj) - ip(jj)=ip(i) - ip(i)=ipj - endif - enddo - do ik=1,nthread - i=ip(ik) - ii=ipatt(1,i) - ist=nres_base(2,ii)+ipatt(2,i) - do kk=1,n_ene_comp - energia(i)=ener0(kk,i) - enddo - etot=ener0(n_ene_comp+1,i) - rmsnat=ener0(n_ene_comp+2,i) - rms=ener0(n_ene_comp+3,i) - frac=ener0(n_ene_comp+4,i) - frac_nn=ener0(n_ene_comp+5,i) - - if (refstr) then - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') & - i,str_nam(ii),ist+1,& - (energia(print_order(kk)),kk=1,nprint_ene),& - etot,rmsnat,frac,frac_nn,rms - else - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3)') & - i,str_nam(ii),ist+1,& - (energia(print_order(kk)),kk=1,nprint_ene),etot - endif - enddo - write (iout,'(//a)') 'Final energies:' - write (iout,'(a4,2x,a12,17a14,3a8)') & - 'No','seq',(ename(print_order(kk)),kk=1,nprint_ene),'ETOT',& - 'RMSnat','NatCONT','NNCONT','RMS' - do ik=1,nthread - i=ip(ik) - ii=ipatt(1,i) - ist=nres_base(2,ii)+ipatt(2,i) - do kk=1,n_ene_comp - energia(kk)=ener(kk,ik) - enddo - etot=ener(n_ene_comp+1,i) - rmsnat=ener(n_ene_comp+2,i) - rms=ener(n_ene_comp+3,i) - frac=ener(n_ene_comp+4,i) - frac_nn=ener(n_ene_comp+5,i) - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') & - i,str_nam(ii),ist+1,& - (energia(print_order(kk)),kk=1,nprint_ene),& - etot,rmsnat,frac,frac_nn,rms - enddo - write (iout,'(/a/)') 'IEXAM array:' - write (iout,'(i5)') nexcl - do i=1,nexcl - write (iout,'(2i5)') iexam(1,i),iexam(2,i) - enddo - write (iout,'(/a,1pe14.4/a,1pe14.4/)') & - 'Max. time for threading step ',max_time_for_thread,& - 'Average time for threading step: ',ave_time_for_thread - return - end subroutine write_thread_summary -!----------------------------------------------------------------------------- - subroutine write_stat_thread(ithread,ipattern,ist) - - use energy_data, only: n_ene_comp - use compare_data -! implicit real*8 (a-h,o-z) -! include "DIMENSIONS" -! include "COMMON.CONTROL" -! include "COMMON.IOUNITS" -! include "COMMON.THREAD" -! include "COMMON.FFIELD" -! include "COMMON.DBASE" -! include "COMMON.NAMES" - real(kind=8),dimension(0:n_ene) :: energia -!el local variables - integer :: ithread,ipattern,ist,i - real(kind=8) :: etot,rmsnat,rms,frac,frac_nn - -#if defined(AIX) || defined(PGI) - open(istat,file=statname,position='append') -#else - open(istat,file=statname,access='append') -#endif - do i=1,n_ene_comp - energia(i)=ener(i,ithread) - enddo - etot=ener(n_ene_comp+1,ithread) - rmsnat=ener(n_ene_comp+2,ithread) - rms=ener(n_ene_comp+3,ithread) - frac=ener(n_ene_comp+4,ithread) - frac_nn=ener(n_ene_comp+5,ithread) - write (istat,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') & - ithread,str_nam(ipattern),ist+1,& - (energia(print_order(i)),i=1,nprint_ene),& - etot,rmsnat,frac,frac_nn,rms - close (istat) - return - end subroutine write_stat_thread -!----------------------------------------------------------------------------- -#endif -!----------------------------------------------------------------------------- - end module io_config diff --git a/source/unres/map.F90 b/source/unres/map.F90 new file mode 100644 index 0000000..b91d43e --- /dev/null +++ b/source/unres/map.F90 @@ -0,0 +1,191 @@ + module map_ +!----------------------------------------------------------------------------- + use io_units + use names + use geometry_data + use control_data + use energy_data + use map_data + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! check_sc_map.f +!----------------------------------------------------------------------------- + subroutine check_sc_map +! Subroutine is checking if the fitted function which describs sc_rot_pot +! is correct, printing, alpha,beta, energy, data - for some known theta. +! theta angle is read from the input file. Sc_rot_pot are printed +! for the second residue in sequance. + use geometry, only:chainbuild + use energy, only:vec_and_deriv,esc +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.INTERACT' + real(kind=8) :: xx,yy,zz,al,om + real(kind=8) :: escloc, escloc_min + real(kind=8),dimension(50000) :: escloc_ene,alph_plot,beta_plot + integer,dimension(5000) :: al_plot,be_plot + integer :: iialph, iibet,it + +!el local variables + integer :: i,j + + write (2,*) "Side-chain-rotamer potential energy map!!!!" + escloc_min = 1000000.00 +! it=itype(2) + i = 0 + do iialph=0,18 + do iibet=-18,18 + i = i + 1 + al = iialph*10.0d0*deg2rad + om = iibet*10.0d0*deg2rad + zz = dcos(al) + xx = -dsin(al)*dcos(om) + yy = -dsin(al)*dsin(om) + alph(2)=dacos(xx) + omeg(2)=-datan2(zz,yy) + al_plot(i)=alph(2)*rad2deg + be_plot(i)=omeg(2)*rad2deg +! write(2,*) alph(2)*rad2deg, omeg(2)*rad2deg + alph_plot(i) = al*rad2deg + beta_plot(i) = om*rad2deg + call chainbuild + call vec_and_deriv + call esc(escloc) + escloc_ene(i) = escloc + if (escloc_min.gt.escloc_ene(i)) escloc_min=escloc_ene(i) + enddo + enddo +! write (2,*) "escloc_min = ", escloc_min + print *,"i",i + do j = 1,i + write (2,'(3f10.3,2i9,f12.5)') alph_plot(j), & + beta_plot(j),theta(3)*rad2deg, al_plot(j),be_plot(j),& + escloc_ene(j) !- escloc_min + enddo + return + end subroutine check_sc_map +!----------------------------------------------------------------------------- +! map.f +!----------------------------------------------------------------------------- + subroutine map + + use geometry, only:chainbuild,geom_to_var + use energy + use minimm, only:minimize +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MAP' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.NAMES' +! include 'COMMON.CONTROL' +! include 'COMMON.TORCNSTR' + real(kind=8) :: energia(0:n_ene) + character(len=5) :: angid(4)=reshape((/'PHI ','THETA','ALPHA',& + 'OMEGA'/),shape(angid)) + real(kind=8) :: ang_list(10) +!el real(kind=8),dimension(6*nres) :: g,x !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(:),allocatable :: g,x !(maxvar) (maxvar=6*maxres) + integer :: nn(10) +!el local variables + integer :: i,iii,ii,j,k,nmax,ntot,nf,iretcode,nfun + real(kind=8) :: etot,gnorm!,fdum + integer,dimension(1) :: uiparm + real(kind=8),dimension(1) :: urparm + allocate(x(6*nres),g(6*nres)) + + write (iout,'(a,i3,a)')'Energy map constructed in the following ',& + nmap,' groups of variables:' + do i=1,nmap + write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ',& + res1(i),' to ',res2(i) + enddo + nmax=nstep(1) + do i=2,nmap + if (nmax.lt.nstep(i)) nmax=nstep(i) + enddo + ntot=nmax**nmap + iii=0 + write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap),& + (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" + do i=0,ntot-1 + ii=i + do j=1,nmap + nn(j)=mod(ii,nmax)+1 + ii=ii/nmax + enddo + do j=1,nmap + if (nn(j).gt.nstep(j)) goto 10 + enddo + iii=iii+1 +!d write (iout,*) i,iii,(nn(j),j=1,nmap) + do j=1,nmap + ang_list(j)=ang_from(j) & + +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) + do k=res1(j),res2(j) + goto (1,2,3,4), kang(j) + 1 phi(k)=deg2rad*ang_list(j) + if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) + goto 5 + 2 theta(k)=deg2rad*ang_list(j) + goto 5 + 3 alph(k)=deg2rad*ang_list(j) + goto 5 + 4 omeg(k)=deg2rad*ang_list(j) + 5 continue + enddo ! k + enddo ! j + call chainbuild + if (minim) then + call geom_to_var(nvar,x) + call minimize(etot,x,iretcode,nfun) + print *,'SUMSL return code is',iretcode,' eval ',nfun +! call intout + else + call zerograd + call geom_to_var(nvar,x) + endif + call etotal(energia) + etot = energia(0) + nf=1 + nfl=3 + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) + gnorm=0.0d0 + do k=1,nvar + gnorm=gnorm+g(k)**2 + enddo + etot=energia(0) + + gnorm=dsqrt(gnorm) +! write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm + write (istat,'(30e15.5)') (ang_list(k),k=1,nmap),& + (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm +! write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) +! call intout +! call enerprint(energia) + 10 continue + enddo ! i +! deallocate(x,g) + return + end subroutine map +!----------------------------------------------------------------------------- + subroutine alloc_map_arrays + +! commom.map +! common /mapp/ + allocate(kang(nmap),res1(nmap),res2(nmap),nstep(nmap)) !(maxvar) + allocate(ang_from(nmap),ang_to(nmap)) !(maxvar) + + return + end subroutine alloc_map_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module map_ diff --git a/source/unres/map.f90 b/source/unres/map.f90 deleted file mode 100644 index b91d43e..0000000 --- a/source/unres/map.f90 +++ /dev/null @@ -1,191 +0,0 @@ - module map_ -!----------------------------------------------------------------------------- - use io_units - use names - use geometry_data - use control_data - use energy_data - use map_data - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! check_sc_map.f -!----------------------------------------------------------------------------- - subroutine check_sc_map -! Subroutine is checking if the fitted function which describs sc_rot_pot -! is correct, printing, alpha,beta, energy, data - for some known theta. -! theta angle is read from the input file. Sc_rot_pot are printed -! for the second residue in sequance. - use geometry, only:chainbuild - use energy, only:vec_and_deriv,esc -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.INTERACT' - real(kind=8) :: xx,yy,zz,al,om - real(kind=8) :: escloc, escloc_min - real(kind=8),dimension(50000) :: escloc_ene,alph_plot,beta_plot - integer,dimension(5000) :: al_plot,be_plot - integer :: iialph, iibet,it - -!el local variables - integer :: i,j - - write (2,*) "Side-chain-rotamer potential energy map!!!!" - escloc_min = 1000000.00 -! it=itype(2) - i = 0 - do iialph=0,18 - do iibet=-18,18 - i = i + 1 - al = iialph*10.0d0*deg2rad - om = iibet*10.0d0*deg2rad - zz = dcos(al) - xx = -dsin(al)*dcos(om) - yy = -dsin(al)*dsin(om) - alph(2)=dacos(xx) - omeg(2)=-datan2(zz,yy) - al_plot(i)=alph(2)*rad2deg - be_plot(i)=omeg(2)*rad2deg -! write(2,*) alph(2)*rad2deg, omeg(2)*rad2deg - alph_plot(i) = al*rad2deg - beta_plot(i) = om*rad2deg - call chainbuild - call vec_and_deriv - call esc(escloc) - escloc_ene(i) = escloc - if (escloc_min.gt.escloc_ene(i)) escloc_min=escloc_ene(i) - enddo - enddo -! write (2,*) "escloc_min = ", escloc_min - print *,"i",i - do j = 1,i - write (2,'(3f10.3,2i9,f12.5)') alph_plot(j), & - beta_plot(j),theta(3)*rad2deg, al_plot(j),be_plot(j),& - escloc_ene(j) !- escloc_min - enddo - return - end subroutine check_sc_map -!----------------------------------------------------------------------------- -! map.f -!----------------------------------------------------------------------------- - subroutine map - - use geometry, only:chainbuild,geom_to_var - use energy - use minimm, only:minimize -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MAP' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.NAMES' -! include 'COMMON.CONTROL' -! include 'COMMON.TORCNSTR' - real(kind=8) :: energia(0:n_ene) - character(len=5) :: angid(4)=reshape((/'PHI ','THETA','ALPHA',& - 'OMEGA'/),shape(angid)) - real(kind=8) :: ang_list(10) -!el real(kind=8),dimension(6*nres) :: g,x !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(:),allocatable :: g,x !(maxvar) (maxvar=6*maxres) - integer :: nn(10) -!el local variables - integer :: i,iii,ii,j,k,nmax,ntot,nf,iretcode,nfun - real(kind=8) :: etot,gnorm!,fdum - integer,dimension(1) :: uiparm - real(kind=8),dimension(1) :: urparm - allocate(x(6*nres),g(6*nres)) - - write (iout,'(a,i3,a)')'Energy map constructed in the following ',& - nmap,' groups of variables:' - do i=1,nmap - write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ',& - res1(i),' to ',res2(i) - enddo - nmax=nstep(1) - do i=2,nmap - if (nmax.lt.nstep(i)) nmax=nstep(i) - enddo - ntot=nmax**nmap - iii=0 - write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap),& - (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" - do i=0,ntot-1 - ii=i - do j=1,nmap - nn(j)=mod(ii,nmax)+1 - ii=ii/nmax - enddo - do j=1,nmap - if (nn(j).gt.nstep(j)) goto 10 - enddo - iii=iii+1 -!d write (iout,*) i,iii,(nn(j),j=1,nmap) - do j=1,nmap - ang_list(j)=ang_from(j) & - +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) - do k=res1(j),res2(j) - goto (1,2,3,4), kang(j) - 1 phi(k)=deg2rad*ang_list(j) - if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) - goto 5 - 2 theta(k)=deg2rad*ang_list(j) - goto 5 - 3 alph(k)=deg2rad*ang_list(j) - goto 5 - 4 omeg(k)=deg2rad*ang_list(j) - 5 continue - enddo ! k - enddo ! j - call chainbuild - if (minim) then - call geom_to_var(nvar,x) - call minimize(etot,x,iretcode,nfun) - print *,'SUMSL return code is',iretcode,' eval ',nfun -! call intout - else - call zerograd - call geom_to_var(nvar,x) - endif - call etotal(energia) - etot = energia(0) - nf=1 - nfl=3 - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - gnorm=0.0d0 - do k=1,nvar - gnorm=gnorm+g(k)**2 - enddo - etot=energia(0) - - gnorm=dsqrt(gnorm) -! write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm - write (istat,'(30e15.5)') (ang_list(k),k=1,nmap),& - (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm -! write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) -! call intout -! call enerprint(energia) - 10 continue - enddo ! i -! deallocate(x,g) - return - end subroutine map -!----------------------------------------------------------------------------- - subroutine alloc_map_arrays - -! commom.map -! common /mapp/ - allocate(kang(nmap),res1(nmap),res2(nmap),nstep(nmap)) !(maxvar) - allocate(ang_from(nmap),ang_to(nmap)) !(maxvar) - - return - end subroutine alloc_map_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module map_ diff --git a/source/unres/math.F90 b/source/unres/math.F90 new file mode 100644 index 0000000..03d12cf --- /dev/null +++ b/source/unres/math.F90 @@ -0,0 +1,834 @@ + module math +!----------------------------------------------------------------------------- + use io_units, only:inp,iout + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! djacob.f +!----------------------------------------------------------------------------- + subroutine DJACOB(N,NMAX,MAXJAC,E,A,C,AII) +! IMPLICIT REAL*8 (A-H,O-Z) +! THE JACOBI DIAGONALIZATION PROCEDURE + integer :: N,NMAX,MAXJAC +! COMMON INP,IOUT,IPN + real(kind=8),DIMENSION(NMAX,N) :: A,C + real(kind=8),DIMENSION(150) :: AJJ !el AII + real(kind=8),DIMENSION(*) :: AII +!el local variables + integer :: l,i,j,k,IPIV,JPIV,IJAC,LIM,LT,IT,IN + real(kind=8) :: e,SIN45,COS45,S45SQ,C45SQ + real(kind=8) :: TEMPA,AIJMAX,TAIJ,TAII,TAJJ,TMT + real(kind=8) :: ZAMMA,SINT,COST,SINSQ,COSSQ,AIIMIN + real(kind=8) :: TAIK,TAJK,TCIK,TCJK,TEST,AMAX,GAMSQ,T + SIN45 = .70710678 + COS45 = .70710678 + S45SQ = 0.50 + C45SQ = 0.50 +! UNIT EIGENVECTOR MATRIX + DO 70 I = 1,N + DO 7 J = I,N + A(J,I)=A(I,J) + C(I,J) = 0.0 + 7 C(J,I) = 0.0 + 70 C(I,I) = 1.0 +! DETERMINATION OF SEARCH ARGUMENT, TEST + AMAX = 0.0 + DO 1 I = 1,N + DO 1 J = 1,I + TEMPA=DABS(A(I,J)) + IF (AMAX-TEMPA) 2,1,1 + 2 AMAX = TEMPA + 1 CONTINUE + TEST = AMAX*E +! SEARCH FOR LARGEST OFF DIAGONAL ELEMENT + DO 72 IJAC=1,MAXJAC + AIJMAX = 0.0 + DO 3 I = 2,N + LIM = I-1 + DO 3 J = 1,LIM + TAIJ=DABS(A(I,J)) + IF (AIJMAX-TAIJ) 4,3,3 + 4 AIJMAX = TAIJ + IPIV = I + JPIV = J + 3 CONTINUE + IF(AIJMAX-TEST)300,300,5 +! PARAMETERS FOR ROTATION + 5 TAII = A(IPIV,IPIV) + TAJJ = A(JPIV,JPIV) + TAIJ = A(IPIV,JPIV) + TMT = TAII-TAJJ + IF(DABS(TMT/TAIJ)-1.0D-12) 60,60,6 + 60 IF(TAIJ) 10,10,11 + 6 ZAMMA=TAIJ/(2.0*TMT) + 90 IF(DABS(ZAMMA)-0.38268)8,8,9 + 9 IF(ZAMMA)10,10,11 + 10 SINT = -SIN45 + GO TO 12 + 11 SINT = SIN45 + 12 COST = COS45 + SINSQ = S45SQ + COSSQ = C45SQ + GO TO 120 + 8 GAMSQ=ZAMMA*ZAMMA + SINT=2.0*ZAMMA/(1.0+GAMSQ) + COST = (1.0-GAMSQ)/(1.0+GAMSQ) + SINSQ=SINT*SINT + COSSQ=COST*COST +! ROTATION + 120 DO 13 K = 1,N + TAIK = A(IPIV,K) + TAJK = A(JPIV,K) + A(IPIV,K) = TAIK*COST+TAJK*SINT + A(JPIV,K) = TAJK*COST-TAIK*SINT + TCIK = C(IPIV,K) + TCJK = C(JPIV,K) + C(IPIV,K) = TCIK*COST+TCJK*SINT + 13 C(JPIV,K) = TCJK*COST-TCIK*SINT + A(IPIV,IPIV) = TAII*COSSQ+TAJJ*SINSQ+2.0*TAIJ*SINT*COST + A(JPIV,JPIV) = TAII*SINSQ+TAJJ*COSSQ-2.0*TAIJ*SINT*COST + A(IPIV,JPIV) = TAIJ*(COSSQ-SINSQ)-SINT*COST*TMT + A(JPIV,IPIV) = A(IPIV,JPIV) + DO 30 K = 1,N + A(K,IPIV) = A(IPIV,K) + 30 A(K,JPIV) = A(JPIV,K) + 72 CONTINUE + WRITE (IOUT,1000) AIJMAX + 1000 FORMAT (/1X,'NONCONVERGENT JACOBI. LARGEST OFF-DIAGONAL ELE',& + 'MENT = ',1PE14.7) +! ARRANGEMENT OF EIGENVALUES IN ASCENDING ORDER + 300 DO 14 I=1,N + 14 AJJ(I)=A(I,I) + LT=N+1 + DO 15 L=1,N + LT=LT-1 + AIIMIN=1.0E+30 + DO 16 I=1,N + IF(AJJ(I)-AIIMIN)17,16,16 + 17 AIIMIN=AJJ(I) + IT=I + 16 CONTINUE + IN=L + AII(IN)=AIIMIN + AJJ(IT)=1.0E+30 + DO 15 K=1,N + 15 A(IN,K)=C(IT,K) + DO 18 I=1,N + IF(A(I,1))19,22,22 + 19 T=-1.0 + GO TO 91 + 22 T=1.0 + 91 DO 18 J=1,N + 18 C(J,I)=T*A(I,J) + return + end subroutine DJACOB +!----------------------------------------------------------------------------- +! energy_p_new_barrier.F +!----------------------------------------------------------------------------- + subroutine vecpr(u,v,w) +! implicit real*8(a-h,o-z) + real(kind=8),dimension(3) :: u,v,w + w(1)=u(2)*v(3)-u(3)*v(2) + w(2)=-u(1)*v(3)+u(3)*v(1) + w(3)=u(1)*v(2)-u(2)*v(1) + return + end subroutine vecpr +!----------------------------------------------------------------------------- + real(kind=8) function scalar(u,v) +!DIR$ INLINEALWAYS scalar +!#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::scalar +!#endif +! implicit none + real(kind=8),dimension(3) :: u,v +!d double precision sc +!d integer i +!d sc=0.0d0 +!d do i=1,3 +!d sc=sc+u(i)*v(i) +!d enddo +!d scalar=sc + + scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) + return + end function scalar +!----------------------------------------------------------------------------- +! sort.f +!----------------------------------------------------------------------------- +! +! +! ################################################### +! ## COPYRIGHT (C) 1990 by Jay William Ponder ## +! ## All Rights Reserved ## +! ################################################### +! +! ######################################################### +! ## ## +! ## subroutine sort -- heapsort of an integer array ## +! ## ## +! ######################################################### +! +! +! "sort" takes an input list of integers and sorts it +! into ascending order using the Heapsort algorithm +! +! + subroutine sort(n,list) +! implicit none + integer :: i,j,k,n + integer :: index,lists + integer :: list(*) +! +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end subroutine sort +!----------------------------------------------------------------------------- +! +! +! ############################################################## +! ## ## +! ## subroutine sort2 -- heapsort of real array with keys ## +! ## ## +! ############################################################## +! +! +! "sort2" takes an input list of reals and sorts it +! into ascending order using the Heapsort algorithm; +! it also returns a key into the original ordering +! +! + subroutine sort2(n,list,key) +! implicit none + integer :: i,j,k,n + integer :: index,keys + integer :: key(*) + real(kind=8) :: lists + real(kind=8) :: list(*) +! +! +! initialize index into the original ordering +! + do i = 1, n + key(i) = i + end do +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + keys = key(k) + else + lists = list(index) + keys = key(index) + list(index) = list(1) + key(index) = key(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + key(1) = keys + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + key(i) = key(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + key(i) = keys + end do + return + end subroutine sort2 +!----------------------------------------------------------------------------- +! +! +! ################################################################# +! ## ## +! ## subroutine sort3 -- heapsort of integer array with keys ## +! ## ## +! ################################################################# +! +! +! "sort3" takes an input list of integers and sorts it +! into ascending order using the Heapsort algorithm; +! it also returns a key into the original ordering +! +! + subroutine sort3(n,list,key) +! implicit none + integer :: i,j,k,n + integer :: index + integer :: lists + integer :: keys + integer :: list(*) + integer :: key(*) +! +! +! initialize index into the original ordering +! + do i = 1, n + key(i) = i + end do +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + keys = key(k) + else + lists = list(index) + keys = key(index) + list(index) = list(1) + key(index) = key(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + key(1) = keys + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + key(i) = key(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + key(i) = keys + end do + return + end subroutine sort3 +!----------------------------------------------------------------------------- +! +! +! ################################################################# +! ## ## +! ## subroutine sort4 -- heapsort of integer absolute values ## +! ## ## +! ################################################################# +! +! +! "sort4" takes an input list of integers and sorts it into +! ascending absolute value using the Heapsort algorithm +! +! + subroutine sort4(n,list) +! implicit none + integer :: i,j,k,n + integer :: index + integer :: lists + integer :: list(*) +! +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1 + end if + if (abs(lists) .lt. abs(list(j))) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end subroutine sort4 +!----------------------------------------------------------------------------- +! +! +! ################################################################ +! ## ## +! ## subroutine sort5 -- heapsort of integer array modulo m ## +! ## ## +! ################################################################ +! +! +! "sort5" takes an input list of integers and sorts it +! into ascending order based on each value modulo "m" +! +! + subroutine sort5(n,list,m) +! implicit none + integer :: i,j,k,m,n + integer :: index,smod + integer :: jmod,j1mod + integer :: lists + integer :: list(*) +! +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + jmod = mod(list(j),m) + j1mod = mod(list(j+1),m) + if (jmod .lt. j1mod) then + j = j + 1 + else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then + j = j + 1 + end if + end if + smod = mod(lists,m) + jmod = mod(list(j),m) + if (smod .lt. jmod) then + list(i) = list(j) + i = j + j = j + j + else if (smod.eq.jmod .and. lists.lt.list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end subroutine sort5 +!----------------------------------------------------------------------------- +! +! +! ############################################################# +! ## ## +! ## subroutine sort6 -- heapsort of a text string array ## +! ## ## +! ############################################################# +! +! +! "sort6" takes an input list of character strings and sorts +! it into alphabetical order using the Heapsort algorithm +! +! + subroutine sort6(n,list) +! implicit none + integer :: i,j,k,n + integer :: index + character(len=256) :: lists + character*(*) :: list(*) +! +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end subroutine sort6 +!----------------------------------------------------------------------------- +! +! +! ################################################################ +! ## ## +! ## subroutine sort7 -- heapsort of text strings with keys ## +! ## ## +! ################################################################ +! +! +! "sort7" takes an input list of character strings and sorts it +! into alphabetical order using the Heapsort algorithm; it also +! returns a key into the original ordering +! +! + subroutine sort7(n,list,key) +! implicit none + integer :: i,j,k,n + integer :: index + integer :: keys + integer :: key(*) + character(len=256) :: lists + character*(*) :: list(*) +! +! +! initialize index into the original ordering +! + do i = 1, n + key(i) = i + end do +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + keys = key(k) + else + lists = list(index) + keys = key(index) + list(index) = list(1) + key(index) = key(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + key(1) = keys + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + key(i) = key(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + key(i) = keys + end do + return + end subroutine sort7 +!----------------------------------------------------------------------------- +! +! +! ######################################################### +! ## ## +! ## subroutine sort8 -- heapsort to unique integers ## +! ## ## +! ######################################################### +! +! +! "sort8" takes an input list of integers and sorts it into +! ascending order using the Heapsort algorithm, duplicate +! values are removed from the final sorted list +! +! + subroutine sort8(n,list) +! implicit none + integer :: i,j,k,n + integer :: index + integer :: lists + integer :: list(*) +! +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists +! +! remove duplicate values from final list +! + j = 1 + do i = 2, n + if (list(i-1) .ne. list(i)) then + j = j + 1 + list(j) = list(i) + end if + end do + if (j .lt. n) n = j + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end subroutine sort8 +!----------------------------------------------------------------------------- +! +! +! ############################################################# +! ## ## +! ## subroutine sort9 -- heapsort to unique text strings ## +! ## ## +! ############################################################# +! +! +! "sort9" takes an input list of character strings and sorts +! it into alphabetical order using the Heapsort algorithm, +! duplicate values are removed from the final sorted list +! +! + subroutine sort9(n,list) +! implicit none + integer :: i,j,k,n + integer :: index + character(len=256) :: lists + character*(*) :: list(*) +! +! +! perform the heapsort of the input list +! + k = n/2 + 1 + index = n + do while (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists +! +! remove duplicate values from final list +! + j = 1 + do i = 2, n + if (list(i-1) .ne. list(i)) then + j = j + 1 + list(j) = list(i) + end if + end do + if (j .lt. n) n = j + return + end if + end if + i = k + j = k + k + do while (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end subroutine sort9 +!----------------------------------------------------------------------------- +! pinorm.f +!----------------------------------------------------------------------------- + real(kind=8) function pinorm(x) +! implicit real*8 (a-h,o-z) +! + use geometry_data, only: pi,dwapi +! this function takes an angle (in radians) and puts it in the range of +! -pi to +pi. +! + integer :: n + real(kind=8) :: x +! include 'COMMON.GEO' + n = x / dwapi + pinorm = x - n * dwapi + if ( pinorm .gt. pi ) then + pinorm = pinorm - dwapi + else if ( pinorm .lt. - pi ) then + pinorm = pinorm + dwapi + end if + return + end function pinorm +!----------------------------------------------------------------------------- +! minimize_p.F +!----------------------------------------------------------------------------- + subroutine xx2x(x,xx) + +! implicit real*8 (a-h,o-z) + use geometry_data + use energy_data +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' + integer :: i,ij,ig,igall + real(kind=8),dimension(6*nres) :: xx,x !(maxvar) (maxvar=6*maxres) + + do i=1,nvar + x(i)=varall(i) + enddo + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + x(igall)=xx(ig) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + x(igall)=xx(ig) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + x(igall)=xx(ig) + endif + endif + enddo + enddo + + return + end subroutine xx2x +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module math diff --git a/source/unres/math.f90 b/source/unres/math.f90 deleted file mode 100644 index 03d12cf..0000000 --- a/source/unres/math.f90 +++ /dev/null @@ -1,834 +0,0 @@ - module math -!----------------------------------------------------------------------------- - use io_units, only:inp,iout - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! djacob.f -!----------------------------------------------------------------------------- - subroutine DJACOB(N,NMAX,MAXJAC,E,A,C,AII) -! IMPLICIT REAL*8 (A-H,O-Z) -! THE JACOBI DIAGONALIZATION PROCEDURE - integer :: N,NMAX,MAXJAC -! COMMON INP,IOUT,IPN - real(kind=8),DIMENSION(NMAX,N) :: A,C - real(kind=8),DIMENSION(150) :: AJJ !el AII - real(kind=8),DIMENSION(*) :: AII -!el local variables - integer :: l,i,j,k,IPIV,JPIV,IJAC,LIM,LT,IT,IN - real(kind=8) :: e,SIN45,COS45,S45SQ,C45SQ - real(kind=8) :: TEMPA,AIJMAX,TAIJ,TAII,TAJJ,TMT - real(kind=8) :: ZAMMA,SINT,COST,SINSQ,COSSQ,AIIMIN - real(kind=8) :: TAIK,TAJK,TCIK,TCJK,TEST,AMAX,GAMSQ,T - SIN45 = .70710678 - COS45 = .70710678 - S45SQ = 0.50 - C45SQ = 0.50 -! UNIT EIGENVECTOR MATRIX - DO 70 I = 1,N - DO 7 J = I,N - A(J,I)=A(I,J) - C(I,J) = 0.0 - 7 C(J,I) = 0.0 - 70 C(I,I) = 1.0 -! DETERMINATION OF SEARCH ARGUMENT, TEST - AMAX = 0.0 - DO 1 I = 1,N - DO 1 J = 1,I - TEMPA=DABS(A(I,J)) - IF (AMAX-TEMPA) 2,1,1 - 2 AMAX = TEMPA - 1 CONTINUE - TEST = AMAX*E -! SEARCH FOR LARGEST OFF DIAGONAL ELEMENT - DO 72 IJAC=1,MAXJAC - AIJMAX = 0.0 - DO 3 I = 2,N - LIM = I-1 - DO 3 J = 1,LIM - TAIJ=DABS(A(I,J)) - IF (AIJMAX-TAIJ) 4,3,3 - 4 AIJMAX = TAIJ - IPIV = I - JPIV = J - 3 CONTINUE - IF(AIJMAX-TEST)300,300,5 -! PARAMETERS FOR ROTATION - 5 TAII = A(IPIV,IPIV) - TAJJ = A(JPIV,JPIV) - TAIJ = A(IPIV,JPIV) - TMT = TAII-TAJJ - IF(DABS(TMT/TAIJ)-1.0D-12) 60,60,6 - 60 IF(TAIJ) 10,10,11 - 6 ZAMMA=TAIJ/(2.0*TMT) - 90 IF(DABS(ZAMMA)-0.38268)8,8,9 - 9 IF(ZAMMA)10,10,11 - 10 SINT = -SIN45 - GO TO 12 - 11 SINT = SIN45 - 12 COST = COS45 - SINSQ = S45SQ - COSSQ = C45SQ - GO TO 120 - 8 GAMSQ=ZAMMA*ZAMMA - SINT=2.0*ZAMMA/(1.0+GAMSQ) - COST = (1.0-GAMSQ)/(1.0+GAMSQ) - SINSQ=SINT*SINT - COSSQ=COST*COST -! ROTATION - 120 DO 13 K = 1,N - TAIK = A(IPIV,K) - TAJK = A(JPIV,K) - A(IPIV,K) = TAIK*COST+TAJK*SINT - A(JPIV,K) = TAJK*COST-TAIK*SINT - TCIK = C(IPIV,K) - TCJK = C(JPIV,K) - C(IPIV,K) = TCIK*COST+TCJK*SINT - 13 C(JPIV,K) = TCJK*COST-TCIK*SINT - A(IPIV,IPIV) = TAII*COSSQ+TAJJ*SINSQ+2.0*TAIJ*SINT*COST - A(JPIV,JPIV) = TAII*SINSQ+TAJJ*COSSQ-2.0*TAIJ*SINT*COST - A(IPIV,JPIV) = TAIJ*(COSSQ-SINSQ)-SINT*COST*TMT - A(JPIV,IPIV) = A(IPIV,JPIV) - DO 30 K = 1,N - A(K,IPIV) = A(IPIV,K) - 30 A(K,JPIV) = A(JPIV,K) - 72 CONTINUE - WRITE (IOUT,1000) AIJMAX - 1000 FORMAT (/1X,'NONCONVERGENT JACOBI. LARGEST OFF-DIAGONAL ELE',& - 'MENT = ',1PE14.7) -! ARRANGEMENT OF EIGENVALUES IN ASCENDING ORDER - 300 DO 14 I=1,N - 14 AJJ(I)=A(I,I) - LT=N+1 - DO 15 L=1,N - LT=LT-1 - AIIMIN=1.0E+30 - DO 16 I=1,N - IF(AJJ(I)-AIIMIN)17,16,16 - 17 AIIMIN=AJJ(I) - IT=I - 16 CONTINUE - IN=L - AII(IN)=AIIMIN - AJJ(IT)=1.0E+30 - DO 15 K=1,N - 15 A(IN,K)=C(IT,K) - DO 18 I=1,N - IF(A(I,1))19,22,22 - 19 T=-1.0 - GO TO 91 - 22 T=1.0 - 91 DO 18 J=1,N - 18 C(J,I)=T*A(I,J) - return - end subroutine DJACOB -!----------------------------------------------------------------------------- -! energy_p_new_barrier.F -!----------------------------------------------------------------------------- - subroutine vecpr(u,v,w) -! implicit real*8(a-h,o-z) - real(kind=8),dimension(3) :: u,v,w - w(1)=u(2)*v(3)-u(3)*v(2) - w(2)=-u(1)*v(3)+u(3)*v(1) - w(3)=u(1)*v(2)-u(2)*v(1) - return - end subroutine vecpr -!----------------------------------------------------------------------------- - real(kind=8) function scalar(u,v) -!DIR$ INLINEALWAYS scalar -!#ifndef OSF -!DEC$ ATTRIBUTES FORCEINLINE::scalar -!#endif -! implicit none - real(kind=8),dimension(3) :: u,v -!d double precision sc -!d integer i -!d sc=0.0d0 -!d do i=1,3 -!d sc=sc+u(i)*v(i) -!d enddo -!d scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end function scalar -!----------------------------------------------------------------------------- -! sort.f -!----------------------------------------------------------------------------- -! -! -! ################################################### -! ## COPYRIGHT (C) 1990 by Jay William Ponder ## -! ## All Rights Reserved ## -! ################################################### -! -! ######################################################### -! ## ## -! ## subroutine sort -- heapsort of an integer array ## -! ## ## -! ######################################################### -! -! -! "sort" takes an input list of integers and sorts it -! into ascending order using the Heapsort algorithm -! -! - subroutine sort(n,list) -! implicit none - integer :: i,j,k,n - integer :: index,lists - integer :: list(*) -! -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end subroutine sort -!----------------------------------------------------------------------------- -! -! -! ############################################################## -! ## ## -! ## subroutine sort2 -- heapsort of real array with keys ## -! ## ## -! ############################################################## -! -! -! "sort2" takes an input list of reals and sorts it -! into ascending order using the Heapsort algorithm; -! it also returns a key into the original ordering -! -! - subroutine sort2(n,list,key) -! implicit none - integer :: i,j,k,n - integer :: index,keys - integer :: key(*) - real(kind=8) :: lists - real(kind=8) :: list(*) -! -! -! initialize index into the original ordering -! - do i = 1, n - key(i) = i - end do -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end subroutine sort2 -!----------------------------------------------------------------------------- -! -! -! ################################################################# -! ## ## -! ## subroutine sort3 -- heapsort of integer array with keys ## -! ## ## -! ################################################################# -! -! -! "sort3" takes an input list of integers and sorts it -! into ascending order using the Heapsort algorithm; -! it also returns a key into the original ordering -! -! - subroutine sort3(n,list,key) -! implicit none - integer :: i,j,k,n - integer :: index - integer :: lists - integer :: keys - integer :: list(*) - integer :: key(*) -! -! -! initialize index into the original ordering -! - do i = 1, n - key(i) = i - end do -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end subroutine sort3 -!----------------------------------------------------------------------------- -! -! -! ################################################################# -! ## ## -! ## subroutine sort4 -- heapsort of integer absolute values ## -! ## ## -! ################################################################# -! -! -! "sort4" takes an input list of integers and sorts it into -! ascending absolute value using the Heapsort algorithm -! -! - subroutine sort4(n,list) -! implicit none - integer :: i,j,k,n - integer :: index - integer :: lists - integer :: list(*) -! -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1 - end if - if (abs(lists) .lt. abs(list(j))) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end subroutine sort4 -!----------------------------------------------------------------------------- -! -! -! ################################################################ -! ## ## -! ## subroutine sort5 -- heapsort of integer array modulo m ## -! ## ## -! ################################################################ -! -! -! "sort5" takes an input list of integers and sorts it -! into ascending order based on each value modulo "m" -! -! - subroutine sort5(n,list,m) -! implicit none - integer :: i,j,k,m,n - integer :: index,smod - integer :: jmod,j1mod - integer :: lists - integer :: list(*) -! -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - jmod = mod(list(j),m) - j1mod = mod(list(j+1),m) - if (jmod .lt. j1mod) then - j = j + 1 - else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then - j = j + 1 - end if - end if - smod = mod(lists,m) - jmod = mod(list(j),m) - if (smod .lt. jmod) then - list(i) = list(j) - i = j - j = j + j - else if (smod.eq.jmod .and. lists.lt.list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end subroutine sort5 -!----------------------------------------------------------------------------- -! -! -! ############################################################# -! ## ## -! ## subroutine sort6 -- heapsort of a text string array ## -! ## ## -! ############################################################# -! -! -! "sort6" takes an input list of character strings and sorts -! it into alphabetical order using the Heapsort algorithm -! -! - subroutine sort6(n,list) -! implicit none - integer :: i,j,k,n - integer :: index - character(len=256) :: lists - character*(*) :: list(*) -! -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end subroutine sort6 -!----------------------------------------------------------------------------- -! -! -! ################################################################ -! ## ## -! ## subroutine sort7 -- heapsort of text strings with keys ## -! ## ## -! ################################################################ -! -! -! "sort7" takes an input list of character strings and sorts it -! into alphabetical order using the Heapsort algorithm; it also -! returns a key into the original ordering -! -! - subroutine sort7(n,list,key) -! implicit none - integer :: i,j,k,n - integer :: index - integer :: keys - integer :: key(*) - character(len=256) :: lists - character*(*) :: list(*) -! -! -! initialize index into the original ordering -! - do i = 1, n - key(i) = i - end do -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end subroutine sort7 -!----------------------------------------------------------------------------- -! -! -! ######################################################### -! ## ## -! ## subroutine sort8 -- heapsort to unique integers ## -! ## ## -! ######################################################### -! -! -! "sort8" takes an input list of integers and sorts it into -! ascending order using the Heapsort algorithm, duplicate -! values are removed from the final sorted list -! -! - subroutine sort8(n,list) -! implicit none - integer :: i,j,k,n - integer :: index - integer :: lists - integer :: list(*) -! -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists -! -! remove duplicate values from final list -! - j = 1 - do i = 2, n - if (list(i-1) .ne. list(i)) then - j = j + 1 - list(j) = list(i) - end if - end do - if (j .lt. n) n = j - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end subroutine sort8 -!----------------------------------------------------------------------------- -! -! -! ############################################################# -! ## ## -! ## subroutine sort9 -- heapsort to unique text strings ## -! ## ## -! ############################################################# -! -! -! "sort9" takes an input list of character strings and sorts -! it into alphabetical order using the Heapsort algorithm, -! duplicate values are removed from the final sorted list -! -! - subroutine sort9(n,list) -! implicit none - integer :: i,j,k,n - integer :: index - character(len=256) :: lists - character*(*) :: list(*) -! -! -! perform the heapsort of the input list -! - k = n/2 + 1 - index = n - do while (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists -! -! remove duplicate values from final list -! - j = 1 - do i = 2, n - if (list(i-1) .ne. list(i)) then - j = j + 1 - list(j) = list(i) - end if - end do - if (j .lt. n) n = j - return - end if - end if - i = k - j = k + k - do while (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end subroutine sort9 -!----------------------------------------------------------------------------- -! pinorm.f -!----------------------------------------------------------------------------- - real(kind=8) function pinorm(x) -! implicit real*8 (a-h,o-z) -! - use geometry_data, only: pi,dwapi -! this function takes an angle (in radians) and puts it in the range of -! -pi to +pi. -! - integer :: n - real(kind=8) :: x -! include 'COMMON.GEO' - n = x / dwapi - pinorm = x - n * dwapi - if ( pinorm .gt. pi ) then - pinorm = pinorm - dwapi - else if ( pinorm .lt. - pi ) then - pinorm = pinorm + dwapi - end if - return - end function pinorm -!----------------------------------------------------------------------------- -! minimize_p.F -!----------------------------------------------------------------------------- - subroutine xx2x(x,xx) - -! implicit real*8 (a-h,o-z) - use geometry_data - use energy_data -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' - integer :: i,ij,ig,igall - real(kind=8),dimension(6*nres) :: xx,x !(maxvar) (maxvar=6*maxres) - - do i=1,nvar - x(i)=varall(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - endif - enddo - enddo - - return - end subroutine xx2x -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module math diff --git a/source/unres/md_calc.F90 b/source/unres/md_calc.F90 new file mode 100644 index 0000000..50f23d7 --- /dev/null +++ b/source/unres/md_calc.F90 @@ -0,0 +1,3365 @@ + module MD_calc +!----------------------------------------------------------------------------- + use io_units + use MD_data, only:D_ban,IP + use geometry_data +! use prng ! prng.f90 or prng_32.f90 + implicit none +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! add.f +!----------------------------------------------------------------------------- + subroutine ABRT + STOP 'IN ABRT' + end subroutine ABRT +!----------------------------------------------------------------------------- +!*MODULE MTHLIB *DECK VCLR + subroutine VCLR(A,INCA,N) +! +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) +! + real(kind=8),DIMENSION(*) :: A +! + real(kind=8),PARAMETER :: ZERO=0.0D+00 + integer :: INCA,N + integer :: l,la +! +! ----- ZERO OUT VECTOR -A-, USING INCREMENT -INCA- ----- +! + IF (INCA .NE. 1) GO TO 200 + DO 110 L=1,N + A(L) = ZERO + 110 CONTINUE + RETURN +! + 200 CONTINUE + LA=1-INCA + DO 210 L=1,N + LA=LA+INCA + A(LA) = ZERO + 210 CONTINUE + return + end subroutine VCLR +!----------------------------------------------------------------------------- +! banach.f +!----------------------------------------------------------------------------- + subroutine BANACH(N,NMAX,A,X,osob) +!********************** +! Banachiewicz +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer :: N,NMAX + real(kind=8),DIMENSION(NMAX,NMAX) :: A + real(kind=8),DIMENSION(NMAX) :: X +!el real(kind=8),DIMENSION(6*nres) :: D !(MAXRES6) maxres6=6*maxres +!el COMMON /BANII/ D + logical :: osob + real(kind=8) :: xx,aij,aijd + integer :: i,j,k,jjjj + +!el allocate(D_ban(6*nres)) + + osob=.false. + if (dabs(a(1,1)).lt.1.0d-15) then + osob=.true. + return + endif + D_ban(1)=1./A(1,1) + DO 80 I=2,N + A(I,1)=A(1,I) + DO 81 J=2,I-1 + XX=A(J,I) + DO 82 K=1,J-1 + XX=XX-A(I,K)*A(J,K) + 82 CONTINUE + A(I,J)=XX + 81 CONTINUE + XX=A(I,I) + JJJJ=I-1 + DO 83 J=1,JJJJ + AIJ=A(I,J) + AIJD=AIJ*D_ban(J) + A(I,J)=AIJD + XX=XX-AIJ*AIJD + 83 CONTINUE + if (dabs(xx).lt.1.0d-15) then + osob=.true. + return + endif + D_ban(I)=1./XX + 80 CONTINUE +! + CALL BANAII(N,NMAX,A,X) + return + end subroutine BANACH +!----------------------------------------------------------------------------- + subroutine BANAII(N,NMAX,A,X) +!************************ +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer :: N,NMAX + real(kind=8),DIMENSION(NMAX,NMAX) :: A + real(kind=8),DIMENSION(NMAX) :: X +!el real(kind=8),DIMENSION(6*nres) :: D !(MAXRES6) maxres6=6*maxres +!el COMMON /BANII/ D ---> D_ban + real(kind=8) :: Z + integer :: i,j,jjjj + DO 90 I=1,N + Z=X(I) + JJJJ=I-1 + DO 91 J=JJJJ,1,-1 + Z=Z-A(I,J)*X(J) + 91 CONTINUE + X(I)=Z + 90 CONTINUE + DO 92 I=N,1,-1 + Z=X(I)*D_ban(I) + JJJJ=I+1 + DO 93 J=JJJJ,N + Z=Z-A(J,I)*X(J) + 93 CONTINUE + X(I)=Z + 92 CONTINUE + return + end subroutine BANAII +!----------------------------------------------------------------------------- + subroutine MATINVERT(N,NMAX,A,A1,osob) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer :: N,NMAX + real(kind=8),DIMENSION(NMAX,NMAX) :: A,A1 +!el real(kind=8),DIMENSION(6*nres) :: D !(MAXRES6) maxres6=6*maxres +!el COMMON /BANII/ D + real(kind=8),DIMENSION(NMAX) :: X + logical :: osob + integer :: i,j + DO I=1,N + X(I)=0.0 + ENDDO + X(1)=1.0 + CALL BANACH(N,NMAX,A,X,osob) + if (osob) return + DO I=1,N + A1(I,1)=X(I) + ENDDO + DO I=2,N + DO J=1,N + X(J)=0.0 + ENDDO + X(I)=1.0 + CALL BANAII(N,NMAX,A,X) + DO J=1,N + A1(J,I)=X(J) + ENDDO + ENDDO + return + end subroutine MATINVERT +!----------------------------------------------------------------------------- +! bond_move.f +!----------------------------------------------------------------------------- + subroutine bond_move(nbond,nstart,psi,lprint,error) + + use mcm_data, only:print_mc + use geometry, only:alpha,beta,refsys,matmult +! Move NBOND fragment starting from the CA(nstart) by angle PSI. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer :: nbond,nstart + real(kind=8) :: psi + logical :: fail,error,lprint +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.MCM' + real(kind=8),dimension(3) :: x,e1,e2,e3 + real(kind=8),dimension(3,3) :: e,rot,trans + real(kind=8) :: cospsi,sinpsi,rij + integer :: i,j,nend,i2,i3,i4,k + error=.false. + nend=nstart+nbond + if (print_mc.gt.2) then + write (iout,*) 'nstart=',nstart,' nend=',nend,' nbond=',nbond + write (iout,*) 'psi=',psi + write (iout,'(a)') 'Original coordinates of the fragment' + do i=nstart,nend + write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) + enddo + endif + if (nstart.lt.1 .or. nend .gt.nres .or. nbond.lt.2 .or. & + nbond.ge.nres-1) then + write (iout,'(a)') 'Bad data in BOND_MOVE.' + error=.true. + return + endif +! Generate the reference system. + i2=nend + i3=nstart + i4=nstart+1 + call refsys(i2,i3,i4,e1,e2,e3,error) +! Return, if couldn't define the reference system. + if (error) return +! Compute the transformation matrix. + cospsi=dcos(psi) + sinpsi=dsin(psi) + rot(1,1)=1.0D0 + rot(1,2)=0.0D0 + rot(1,3)=0.0D0 + rot(2,1)=0.0D0 + rot(2,2)=cospsi + rot(2,3)=-sinpsi + rot(3,1)=0.0D0 + rot(3,2)=sinpsi + rot(3,3)=cospsi + do i=1,3 + e(1,i)=e1(i) + e(2,i)=e2(i) + e(3,i)=e3(i) + enddo + + if (print_mc.gt.2) then + write (iout,'(a)') 'Reference system and matrix r:' + do i=1,3 + write(iout,'(i5,2(3f10.5,5x))')i,(e(i,j),j=1,3),(rot(i,j),j=1,3) + enddo + endif + + call matmult(rot,e,trans) + do i=1,3 + do j=1,3 + e(i,1)=e1(i) + e(i,2)=e2(i) + e(i,3)=e3(i) + enddo + enddo + call matmult(e,trans,trans) + + if (lprint) then + write (iout,'(a)') 'The trans matrix:' + do i=1,3 + write (iout,'(i5,3f10.5)') i,(trans(i,j),j=1,3) + enddo + endif + + do i=nstart,nend + do j=1,3 + rij=c(j,nstart) + do k=1,3 + rij=rij+trans(j,k)*(c(k,i)-c(k,nstart)) + enddo + x(j)=rij + enddo + do j=1,3 + c(j,i)=x(j) + enddo + enddo + + if (lprint) then + write (iout,'(a)') 'Rotated coordinates of the fragment' + do i=nstart,nend + write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) + enddo + endif + +! call int_from_cart(.false.,lprint) + if (nstart.gt.1) then + theta(nstart+1)=alpha(nstart-1,nstart,nstart+1) + phi(nstart+2)=beta(nstart-1,nstart,nstart+1,nstart+2) + if (nstart.gt.2) phi(nstart+1)= & + beta(nstart-2,nstart-1,nstart,nstart+1) + endif + if (nend.lt.nres) then + theta(nend+1)=alpha(nend-1,nend,nend+1) + phi(nend+1)=beta(nend-2,nend-1,nend,nend+1) + if (nend.lt.nres-1) phi(nend+2)= & + beta(nend-1,nend,nend+1,nend+2) + endif + if (print_mc.gt.2) then + write (iout,'(/a,i3,a,i3,a/)') & + 'Moved internal coordinates of the ',nstart,'-',nend,& + ' fragment:' + do i=nstart+1,nstart+2 + write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) + enddo + do i=nend+1,nend+2 + write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end subroutine bond_move +!----------------------------------------------------------------------------- +! eigen.f +!----------------------------------------------------------------------------- +! 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS +! 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON +! 26 JUN 93 - MWS - ETRED3: ADD RETURN FOR SPECIAL CASE N=1 +! 4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR +! 30 AUG 91 - MWS - JACDIA: LIMIT ITERATIONS, USE EPSLON IN TEST. +! 14 JUL 91 - MWS - JACOBI DIAGONALIZATION ALLOWS FOR LDVEC.NE.N +! 29 JAN 91 - TLW - GLDIAG: CHANGED COMMON DIAGSW TO MACHSW +! 29 OCT 90 - STE - FIX JACDIA UNDEFINED VARIABLE BUG +! 14 SEP 90 - MK - NEW JACOBI DIAGONALIZATION (KDIAG=3) +! 27 MAR 88 - MWS - ALLOW FOR VECTOR ROUTINE IN GLDIAG +! 11 AUG 87 - MWS - SANITIZE CONSTANTS IN EQLRAT +! 15 FEB 87 - STE - FIX EINVIT SUB-MATRIX LOOP LIMIT +! SCRATCH ARRAYS ARE N*8 REAL AND N INTEGER +! 8 DEC 86 - STE - USE PERF INDEX FROM ESTPI1 TO JUDGE EINVIT FAILURE +! 30 NOV 86 - STE - DELETE LIGENB, MAKE EVVRSP DEFAULT +! (GIVEIS FAILS ON CRAY FOR BENCHMC AND BENCHCI) +! 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS +! 11 OCT 85 - STE - LIGENB,TQL2: USE DROT,DSWAP; TINVTB: SCALE VECTOR +! BEFORE NORMALIZING; GENERIC FUNCTIONS +! 24 FEB 84 - STE - INITIALIZE INDEX ARRAY FOR LIGENB IN GLDIAG +! 1 DEC 83 - STE - CHANGE MACHEP FROM 2**-54 TO 2**-50 +! 28 SEP 82 - MWS - CONVERT TO IBM +! +!*MODULE EIGEN *DECK EINVIT + subroutine EINVIT(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) +!* +!* AUTHORS- +!* THIS IS A MODIFICATION OF TINVIT FROM EISPACK EDITION 3 +!* DATED AUGUST 1983. +!* TINVIT IS A TRANSLATION OF THE INVERSE ITERATION TECHNIQUE +!* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. +!* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). +!* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) +!* +!* PURPOSE - +!* THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL +!* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES. +!* +!* METHOD - +!* INVERSE ITERATION. +!* +!* ON ENTRY - +!* NM - INTEGER +!* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +!* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +!* DIMENSION STATEMENT. +!* N - INTEGER +!* D - W.P. REAL (N) +!* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. +!* E - W.P. REAL (N) +!* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +!* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. +!* E2 - W.P. REAL (N) +!* CONTAINS THE SQUARES OF CORRESPONDING ELEMENTS OF E, +!* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. +!* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN +!* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE +!* SUM OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST +!* CONTAIN 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, +!* OR 2.0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. +!* IF TQLRAT, BISECT, TRIDIB, OR IMTQLV +!* HAS BEEN USED TO FIND THE EIGENVALUES, THEIR +!* OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. +!* M - INTEGER +!* THE NUMBER OF SPECIFIED EIGENVECTORS. +!* W - W.P. REAL (M) +!* CONTAINS THE M EIGENVALUES IN ASCENDING +!* OR DESCENDING ORDER. +!* IND - INTEGER (M) +!* CONTAINS IN FIRST M POSITIONS THE SUBMATRIX INDICES +!* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- +!* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX +!* FROM THE TOP, 2 FOR THOSE BELONGING TO THE SECOND +!* SUBMATRIX, ETC. +!* IERR - INTEGER (LOGICAL UNIT NUMBER) +!* LOGICAL UNIT FOR ERROR MESSAGES +!* +!* ON EXIT - +!* ALL INPUT ARRAYS ARE UNALTERED. +!* Z - W.P. REAL (NM,M) +!* CONTAINS THE ASSOCIATED SET OF ORTHONORMAL +!* EIGENVECTORS. ANY VECTOR WHICH WHICH FAILS TO CONVERGE +!* IS LEFT AS IS (BUT NORMALIZED) WHEN ITERATING STOPPED. +!* IERR - INTEGER +!* SET TO +!* ZERO FOR NORMAL RETURN, +!* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH +!* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. +!* (ONLY LAST FAILURE TO CONVERGE IS REPORTED) +!* +!* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. +!* +!* RV1 - W.P. REAL (N) +!* DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION +!* RV2 - W.P. REAL (N) +!* SUPER(1)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION +!* RV3 - W.P. REAL (N) +!* SUPER(2)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION +!* RV4 - W.P. REAL (N) +!* ELEMENTS DEFINING L IN LU DECOMPOSITION +!* RV6 - W.P. REAL (N) +!* APPROXIMATE EIGENVECTOR +!* +!* DIFFERENCES FROM EISPACK 3 - +!* EPS3 IS SCALED BY EPSCAL (ENHANCES CONVERGENCE, BUT +!* LOWERS ACCURACY)! +!* ONE MORE ITERATION (MINIMUM 2) IS PERFORMED AFTER CONVERGENCE +!* (ENHANCES ACCURACY)! +!* REPLACE LOOP WITH PYTHAG WITH SINGLE CALL TO DNRM2! +!* IF NOT CONVERGED, USE PERFORMANCE INDEX TO DECIDE ON ERROR +!* VALUE SETTING, BUT DO NOT STOP! +!* L.U. FOR ERROR MESSAGES PASSED THROUGH IERR +!* USE PARAMETER STATEMENTS AND GENERIC INTRINSIC FUNCTIONS +!* USE LEVEL 1 BLAS +!* USE IF-THEN-ELSE TO CLARIFY LOGIC +!* LOOP OVER SUBSPACES MADE INTO DO LOOP. +!* LOOP OVER INVERSE ITERATIONS MADE INTO DO LOOP +!* ZERO ONLY REQUIRED PORTIONS OF OUTPUT VECTOR +!* +!* NOTE - +!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +!* +! + use comm_par + LOGICAL :: CONVGD !el,GOPARR,DSKWRK,MASWRK +! + INTEGER :: GROUP,I,IERR,ITS,J,JJ,M,N,NM,P,Q,R,S,SUBMAT,TAG + INTEGER :: IND(M) +! + real(kind=8),dimension(N) :: D,E2 + real(kind=8) :: E(*)!el E(L) + real(kind=8) :: W(M),Z(NM,M) + real(kind=8),dimension(N) :: RV1,RV2,RV3,RV4,RV6 + real(kind=8) :: ANORM,EPS2,EPS3,EPS4,NORM,ORDER,RHO,U,UK,V + real(kind=8) :: X0,X1,XU +! real(kind=8) :: ESTPI1 !, DASUM, DDOT, DNRM2 EPSLON, +! +!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM +!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +! + real(kind=8),PARAMETER :: ZERO = 0.0D+00, ONE = 1.0D+00, GRPTOL = 0.001D+00 + real(kind=8),PARAMETER :: EPSCAL = 0.5D+00, HUNDRD = 100.0D+00, TEN = 10.0D+00 +! + 001 FORMAT(' EIGENVECTOR ROUTINE EINVIT DID NOT CONVERGE FOR VECTOR' & + ,I5,'. NORM =',1P,E10.2,' PERFORMANCE INDEX =',E10.2/ & + ' (AN ERROR HALT WILL OCCUR IF THE PI IS GREATER THAN 100)') + integer :: LUEMSG +! +!----------------------------------------------------------------------- +! + LUEMSG = IERR + IERR = 0 + X0 = ZERO + UK = ZERO + NORM = ZERO + EPS2 = ZERO + EPS3 = ZERO + EPS4 = ZERO + GROUP = 0 + TAG = 0 + ORDER = ONE - E2(1) + Q = 0 + DO 930 SUBMAT = 1, N + P = Q + 1 +! +! .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... +! + DO 120 Q = P, N-1 + IF (E2(Q+1) .EQ. ZERO) GO TO 140 + 120 CONTINUE + Q = N +! +! .......... FIND VECTORS BY INVERSE ITERATION .......... +! + 140 CONTINUE + TAG = TAG + 1 + ANORM = ZERO + S = 0 +! + DO 920 R = 1, M + IF (IND(R) .NE. TAG) GO TO 920 + ITS = 1 + X1 = W(R) + IF (S .NE. 0) GO TO 510 +! +! .......... CHECK FOR ISOLATED ROOT .......... +! + XU = ONE + IF (P .EQ. Q) THEN + RV6(P) = ONE + CONVGD = .TRUE. + GO TO 860 +! + END IF + NORM = ABS(D(P)) + DO 500 I = P+1, Q + NORM = MAX( NORM, ABS(D(I)) + ABS(E(I)) ) + 500 CONTINUE +! +! .......... EPS2 IS THE CRITERION FOR GROUPING, +! EPS3 REPLACES ZERO PIVOTS AND EQUAL +! ROOTS ARE MODIFIED BY EPS3, +! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... +! + EPS2 = GRPTOL * NORM + EPS3 = EPSCAL * EPSLON(NORM) + UK = Q - P + 1 + EPS4 = UK * EPS3 + UK = EPS4 / SQRT(UK) + S = P + GROUP = 0 + GO TO 520 +! +! .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... +! + 510 IF (ABS(X1-X0) .GE. EPS2) THEN +! +! ROOTS ARE SEPERATE +! + GROUP = 0 + ELSE +! +! ROOTS ARE CLOSE +! + GROUP = GROUP + 1 + IF (ORDER * (X1 - X0) .LE. EPS3) X1 = X0 + ORDER * EPS3 + END IF +! +! .......... ELIMINATION WITH INTERCHANGES AND +! INITIALIZATION OF VECTOR .......... +! + 520 CONTINUE +! + U = D(P) - X1 + V = E(P+1) + RV6(P) = UK + DO 550 I = P+1, Q + RV6(I) = UK + IF (ABS(E(I)) .GT. ABS(U)) THEN +! +! EXCHANGE ROWS BEFORE ELIMINATION +! +! *** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF +! E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ....... +! + XU = U / E(I) + RV4(I) = XU + RV1(I-1) = E(I) + RV2(I-1) = D(I) - X1 + RV3(I-1) = E(I+1) + U = V - XU * RV2(I-1) + V = -XU * RV3(I-1) +! + ELSE +! +! STRAIGHT ELIMINATION +! + XU = E(I) / U + RV4(I) = XU + RV1(I-1) = U + RV2(I-1) = V + RV3(I-1) = ZERO + U = D(I) - X1 - XU * V + V = E(I+1) + END IF + 550 CONTINUE +! + IF (ABS(U) .LE. EPS3) U = EPS3 + RV1(Q) = U + RV2(Q) = ZERO + RV3(Q) = ZERO +! +! DO INVERSE ITERATIONS +! + CONVGD = .FALSE. + DO 800 ITS = 1, 5 + IF (ITS .EQ. 1) GO TO 600 +! +! .......... FORWARD SUBSTITUTION .......... +! + IF (NORM .EQ. ZERO) THEN + RV6(S) = EPS4 + S = S + 1 + IF (S .GT. Q) S = P + ELSE + XU = EPS4 / NORM + CALL DSCAL (Q-P+1, XU, RV6(P), 1) + END IF +! +! ... ELIMINATION OPERATIONS ON NEXT VECTOR +! + DO 590 I = P+1, Q + U = RV6(I) +! +! IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE +! WAS PERFORMED EARLIER IN THE +! TRIANGULARIZATION PROCESS .......... +! + IF (RV1(I-1) .EQ. E(I)) THEN + U = RV6(I-1) + RV6(I-1) = RV6(I) + ELSE + U = RV6(I) + END IF + RV6(I) = U - RV4(I) * RV6(I-1) + 590 CONTINUE + 600 CONTINUE +! +! .......... BACK SUBSTITUTION +! + RV6(Q) = RV6(Q) / RV1(Q) + V = U + U = RV6(Q) + NORM = ABS(U) + DO 620 I = Q-1, P, -1 + RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) + V = U + U = RV6(I) + NORM = NORM + ABS(U) + 620 CONTINUE + IF (GROUP .EQ. 0) GO TO 700 +! +! ....... ORTHOGONALIZE WITH RESPECT TO PREVIOUS +! MEMBERS OF GROUP .......... +! + J = R + DO 680 JJ = 1, GROUP + 630 J = J - 1 + IF (IND(J) .NE. TAG) GO TO 630 + CALL DAXPY(Q-P+1, -DDOT(Q-P+1,RV6(P),1,Z(P,J),1),& + Z(P,J),1,RV6(P),1) + 680 CONTINUE + NORM = DASUM(Q-P+1, RV6(P), 1) + 700 CONTINUE +! + IF (CONVGD) GO TO 840 + IF (NORM .GE. ONE) CONVGD = .TRUE. + 800 CONTINUE +! +! .......... NORMALIZE SO THAT SUM OF SQUARES IS +! 1 AND EXPAND TO FULL ORDER .......... +! + 840 CONTINUE +! + XU = ONE / DNRM2(Q-P+1,RV6(P),1) +! + 860 CONTINUE + DO 870 I = 1, P-1 + Z(I,R) = ZERO + 870 CONTINUE + DO 890 I = P,Q + Z(I,R) = RV6(I) * XU + 890 CONTINUE + DO 900 I = Q+1, N + Z(I,R) = ZERO + 900 CONTINUE +! + IF (.NOT.CONVGD) THEN + RHO = ESTPI1(Q-P+1,X1,D(P),E(P),Z(P,R),ANORM) + IF (RHO .GE. TEN .AND. LUEMSG .GT. 0 .AND. MASWRK) & + WRITE(LUEMSG,001) R,NORM,RHO +! +! *** SET ERROR -- NON-CONVERGED EIGENVECTOR .......... +! + IF (RHO .GT. HUNDRD) IERR = -R + END IF +! + X0 = X1 + 920 CONTINUE +! + IF (Q .EQ. N) GO TO 940 + 930 CONTINUE + 940 CONTINUE + return + end subroutine EINVIT +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK ELAUM + subroutine ELAU(HINV,L,D,A,E) +! + integer :: L,JL,JK,J,JM1,K + real(kind=8) :: A(*) + real(kind=8) :: D(L) +!el real(kind=8) :: E(L) + real(kind=8) :: E(*)!el E(L) + real(kind=8) :: F + real(kind=8) :: G + real(kind=8) :: HH + real(kind=8) :: HINV +! + real(kind=8),PARAMETER :: ZERO = 0.0D+00, HALF = 0.5D+00 +! + JL = L + E(1) = A(1) * D(1) + JK = 2 + DO 210 J = 2, JL + F = D(J) + G = ZERO + JM1 = J - 1 +! + DO 200 K = 1, JM1 + G = G + A(JK) * D(K) + E(K) = E(K) + A(JK) * F + JK = JK + 1 + 200 CONTINUE +! + E(J) = G + A(JK) * F + JK = JK + 1 + 210 CONTINUE +! +! .......... FORM P .......... +! + F = ZERO + DO 245 J = 1, L + E(J) = E(J) * HINV + F = F + E(J) * D(J) + 245 CONTINUE +! +! .......... FORM Q .......... +! + HH = F * HALF * HINV + DO 250 J = 1, L + 250 E(J) = E(J) - HH * D(J) +! + return + end subroutine ELAU +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK EPSLON + real(kind=8) function EPSLON(X) +!* +!* AUTHORS - +!* THIS ROUTINE WAS TAKEN FROM EISPACK EDITION 3 DATED 4/6/83 +!* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE NOV 1986 +!* +!* PURPOSE - +!* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. +!* +!* ON ENTRY - +!* X - WORKING PRECISION REAL +!* VALUES TO FIND EPSLON FOR +!* +!* ON EXIT - +!* EPSLON - WORKING PRECISION REAL +!* SMALLEST POSITIVE VALUE SUCH THAT X+EPSLON .NE. ZERO +!* +!* QUALIFICATIONS - +!* THIS ROUTINE SHOULD PERFORM PROPERLY ON ALL SYSTEMS +!* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, +!* 1. THE BASE USED IN REPRESENTING FLOATING POINT +!* NUMBERS IS NOT A POWER OF THREE. +!* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO +!* THE ACCURACY USED IN FLOATING POINT VARIABLES +!* THAT ARE STORED IN MEMORY. +!* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO +!* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING +!* ASSUMPTION 2. +!* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, +!* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, +!* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, +!* C IS NOT EXACTLY EQUAL TO ONE, +!* EPS MEASURES THE SEPARATION OF 1.0 FROM +!* THE NEXT LARGER FLOATING POINT NUMBER. +!* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED +!* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. +!* +!* DIFFERENCES FROM EISPACK 3 - +!* USE IS MADE OF PARAMETER STATEMENTS AND INTRINSIC FUNCTIONS +!* --NO EXECUTEABLE CODE CHANGES-- +!* +!* NOTE - +!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +! + real(kind=8) :: A,B,C,EPS,X +! + real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00, THREE=3.0D+00, FOUR=4.0D+00 +! +!----------------------------------------------------------------------- +! + A = FOUR/THREE + 10 B = A - ONE + C = B + B + B + EPS = ABS(C - ONE) + IF (EPS .EQ. ZERO) GO TO 10 + EPSLON = EPS*ABS(X) + return + end function EPSLON +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK EQLRAT + subroutine EQLRAT(N,DIAG,E,E2IN,D,IND,IERR,E2) +!* +!* AUTHORS - +!* THIS IS A MODIFICATION OF ROUTINE EQLRAT FROM EISPACK EDITION 3 +!* DATED AUGUST 1983. +!* TQLRAT IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, +!* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. +!* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) +!* +!* PURPOSE - +!* THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC +!* TRIDIAGONAL MATRIX +!* +!* METHOD - +!* RATIONAL QL +!* +!* ON ENTRY - +!* N - INTEGER +!* THE ORDER OF THE MATRIX. +!* D - W.P. REAL (N) +!* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. +!* E2 - W.P. REAL (N) +!* CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF +!* THE INPUT MATRIX IN ITS LAST N-1 POSITIONS. +!* E2(1) IS ARBITRARY. +!* +!* ON EXIT - +!* D - W.P. REAL (N) +!* CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +!* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND +!* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE +!* THE SMALLEST EIGENVALUES. +!* E2 - W.P. REAL (N) +!* DESTROYED. +!* IERR - INTEGER +!* SET TO +!* ZERO FOR NORMAL RETURN, +!* J IF THE J-TH EIGENVALUE HAS NOT BEEN +!* DETERMINED AFTER 30 ITERATIONS. +!* +!* DIFFERENCES FROM EISPACK 3 - +!* G=G+B INSTEAD OF IF(G.EQ.0) G=B ; B=B/4 +!* F77 BACKWARD LOOPS INSTEAD OF F66 CONSTRUCT +!* GENERIC INTRINSIC FUNCTIONS +!* ARRARY IND ADDED FOR USE BY EINVIT +!* +!* NOTE - +!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +! + INTEGER :: I,J,L,M,N,II,L1,IERR + INTEGER,dimension(N) :: IND +! + real(kind=8),dimension(N) :: D,E,E2,DIAG,E2IN + real(kind=8) :: B,C,F,G,H,P,R,S,T !,EPSLON +! + real(kind=8),PARAMETER :: ZERO = 0.0D+00, SCALE= 1.0D+00/64.0D+00, ONE = 1.0D+00 +! + integer :: K,ITAG +!----------------------------------------------------------------------- + IERR = 0 + D(1)=DIAG(1) + IND(1) = 1 + K = 0 + ITAG = 0 + IF (N .EQ. 1) GO TO 1001 +! + DO 100 I = 2, N + D(I)=DIAG(I) + 100 E2(I-1) = E2IN(I) +! + F = ZERO + T = ZERO + B = EPSLON(ONE) + C = B *B + B = B * SCALE + E2(N) = ZERO +! + DO 290 L = 1, N + H = ABS(D(L)) + ABS(E(L)) + IF (T .GE. H) GO TO 105 + T = H + B = EPSLON(T) + C = B * B + B = B * SCALE + 105 CONTINUE +! .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... + M = L - 1 + 110 M = M + 1 + IF (E2(M) .GT. C) GO TO 110 +! .......... E2(N) IS ALWAYS ZERO, SO THERE IS AN EXIT +! FROM THE LOOP .......... +! + IF (M .LE. K) GO TO 125 + IF (M .NE. N) E2IN(M+1) = ZERO + K = M + ITAG = ITAG + 1 + 125 CONTINUE + IF (M .EQ. L) GO TO 210 +! +! ITERATE +! + DO 205 J = 1, 30 +! .......... FORM SHIFT .......... + L1 = L + 1 + S = SQRT(E2(L)) + G = D(L) + P = (D(L1) - G) / (2.0D+00 * S) + R = SQRT(P*P+1.0D+00) + D(L) = S / (P + SIGN(R,P)) + H = G - D(L) +! + DO 140 I = L1, N + 140 D(I) = D(I) - H +! + F = F + H +! .......... RATIONAL QL TRANSFORMATION .......... + G = D(M) + B + H = G + S = ZERO + DO 200 I = M-1,L,-1 + P = G * H + R = P + E2(I) + E2(I+1) = S * R + S = E2(I) / R + D(I+1) = H + S * (H + D(I)) + G = D(I) - E2(I) / G + B + H = G * P / R + 200 CONTINUE +! + E2(L) = S * G + D(L) = H +! .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST + IF (H .EQ. ZERO) GO TO 210 + IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 + E2(L) = H * E2(L) + IF (E2(L) .EQ. ZERO) GO TO 210 + 205 CONTINUE +! .......... SET ERROR -- NO CONVERGENCE TO AN +! EIGENVALUE AFTER 30 ITERATIONS .......... + IERR = L + GO TO 1001 +! +! CONVERGED +! + 210 P = D(L) + F +! .......... ORDER EIGENVALUES .......... + I = 1 + IF (L .EQ. 1) GO TO 250 + IF (P .LT. D(1)) GO TO 230 + I = L +! .......... LOOP TO FIND ORDERED POSITION + 220 I = I - 1 + IF (P .LT. D(I)) GO TO 220 +! + I = I + 1 + IF (I .EQ. L) GO TO 250 + 230 CONTINUE + DO 240 II = L, I+1, -1 + D(II) = D(II-1) + IND(II) = IND(II-1) + 240 CONTINUE +! + 250 CONTINUE + D(I) = P + IND(I) = ITAG + 290 CONTINUE +! + 1001 return + end subroutine EQLRAT +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK ESTPI1 + real(kind=8) function ESTPI1(N,EVAL,D,E,X,ANORM) +!* +!* AUTHOR - +!* STEPHEN T. ELBERT (AMES LABORATORY-USDOE) DATE: 5 DEC 1986 +!* +!* PURPOSE - +!* EVALUATE SYMMETRIC TRIDIAGONAL MATRIX PERFORMANCE INDEX +!* * * * * * +!* FOR 1 EIGENVECTOR +!* * +!* +!* METHOD - +!* THIS ROUTINE FORMS THE 1-NORM OF THE RESIDUAL MATRIX A*X-X*EVAL +!* WHERE A IS A SYMMETRIC TRIDIAGONAL MATRIX STORED +!* IN THE DIAGONAL (D) AND SUB-DIAGONAL (E) VECTORS, EVAL IS THE +!* EIGENVALUE OF AN EIGENVECTOR OF A, NAMELY X. +!* THIS NORM IS SCALED BY MACHINE ACCURACY FOR THE PROBLEM SIZE. +!* ALL NORMS APPEARING IN THE COMMENTS BELOW ARE 1-NORMS. +!* +!* ON ENTRY - +!* N - INTEGER +!* THE ORDER OF THE MATRIX A. +!* EVAL - W.P. REAL +!* THE EIGENVALUE CORRESPONDING TO VECTOR X. +!* D - W.P. REAL (N) +!* THE DIAGONAL VECTOR OF A. +!* E - W.P. REAL (N) +!* THE SUB-DIAGONAL VECTOR OF A. +!* X - W.P. REAL (N) +!* AN EIGENVECTOR OF A. +!* ANORM - W.P. REAL +!* THE NORM OF A IF IT HAS BEEN PREVIOUSLY COMPUTED. +!* +!* ON EXIT - +!* ANORM - W.P. REAL +!* THE NORM OF A, COMPUTED IF INITIALLY ZERO. +!* ESTPI1 - W.P. REAL +!* !!A*X-X*EVAL!! / (EPSLON(10*N)*!!A!!*!!X!!); +!* WHERE EPSLON(X) IS THE SMALLEST NUMBER SUCH THAT +!* X + EPSLON(X) .NE. X +!* +!* ESTPI1 .LT. 1 == SATISFACTORY PERFORMANCE +!* .GE. 1 AND .LE. 100 == MARGINAL PERFORMANCE +!* .GT. 100 == POOR PERFORMANCE +!* (SEE LECT. NOTES IN COMP. SCI. VOL.6 PP 124-125) +! + integer :: N,I + real(kind=8) :: ANORM,EVAL,RNORM,SIZE,XNORM + real(kind=8),dimension(N) :: D,X + real(kind=8) :: E(*)!el E(L) +! real(kind=8) :: EPSLON +! + real(kind=8),PARAMETER :: ZERO = 0.0D+00, ONE = 1.0D+00 +! +!----------------------------------------------------------------------- +! + ESTPI1 = ZERO + IF( N .LE. 1 ) RETURN + SIZE = 10 * N + IF (ANORM .EQ. ZERO) THEN +! +! COMPUTE NORM OF A +! + ANORM = MAX( ABS(D(1)) + ABS(E(2)), & + ABS(D(N)) + ABS(E(N))) + DO 110 I = 2, N-1 + ANORM = MAX( ANORM, ABS(E(I))+ABS(D(I))+ABS(E(I+1))) + 110 CONTINUE + IF(ANORM .EQ. ZERO) ANORM = ONE + END IF +! +! COMPUTE NORMS OF RESIDUAL AND EIGENVECTOR +! + XNORM = ABS(X(1)) + ABS(X(N)) + RNORM = ABS( (D(1)-EVAL)*X(1) + E(2)*X(2)) & + +ABS( (D(N)-EVAL)*X(N) + E(N)*X(N-1)) + DO 120 I = 2, N-1 + XNORM = XNORM + ABS(X(I)) + RNORM = RNORM + ABS(E(I)*X(I-1) + (D(I)-EVAL)*X(I) & + + E(I+1)*X(I+1)) + 120 CONTINUE +! + ESTPI1 = RNORM / (EPSLON(SIZE)*ANORM*XNORM) + return + end function ESTPI1 +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK ETRBK3 + subroutine ETRBK3(NM,N,NV,A,M,Z) +!* +!* AUTHORS- +!* THIS IS A MODIFICATION OF ROUTINE TRBAK3 FROM EISPACK EDITION 3 +!* DATED AUGUST 1983. +!* EISPACK TRBAK3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, +!* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +!* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +!* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) +!* +!* PURPOSE - +!* THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC +!* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +!* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY ETRED3. +!* +!* METHOD - +!* THE CALCULATION IS CARRIED OUT BY FORMING THE MATRIX PRODUCT +!* Q*Z +!* WHERE Q IS A PRODUCT OF THE ORTHOGONAL SYMMETRIC MATRICES +!* Q = PROD(I)[1 - U(I)*.TRANSPOSE.U(I)*H(I)] +!* U IS THE AUGMENTED SUB-DIAGONAL ROWS OF A AND +!* Z IS THE SET OF EIGENVECTORS OF THE TRIDIAGONAL +!* MATRIX F WHICH WAS FORMED FROM THE ORIGINAL SYMMETRIC +!* MATRIX C BY THE SIMILARITY TRANSFORMATION +!* F = Q(TRANSPOSE) C Q +!* NOTE THAT ETRBK3 PRESERVES VECTOR EUCLIDEAN NORMS. +!* +!* +!* COMPLEXITY - +!* M*N**2 +!* +!* ON ENTRY- +!* NM - INTEGER +!* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +!* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +!* DIMENSION STATEMENT. +!* N - INTEGER +!* THE ORDER OF THE MATRIX A. +!* NV - INTEGER +!* MUST BE SET TO THE DIMENSION OF THE ARRAY A AS +!* DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT. +!* A - W.P. REAL (NV) +!* CONTAINS INFORMATION ABOUT THE ORTHOGONAL +!* TRANSFORMATIONS USED IN THE REDUCTION BY ETRED3 IN +!* ITS FIRST NV = N*(N+1)/2 POSITIONS. +!* M - INTEGER +!* THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. +!* Z - W.P REAL (NM,M) +!* CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED +!* IN ITS FIRST M COLUMNS. +!* +!* ON EXIT- +!* Z - W.P. REAL (NM,M) +!* CONTAINS THE TRANSFORMED EIGENVECTORS +!* IN ITS FIRST M COLUMNS. +!* +!* DIFFERENCES WITH EISPACK 3 - +!* THE TWO INNER LOOPS ARE REPLACED BY DDOT AND DAXPY. +!* MULTIPLICATION USED INSTEAD OF DIVISION TO FIND S. +!* OUTER LOOP RANGE CHANGED FROM 2,N TO 3,N. +!* ADDRESS POINTERS FOR A SIMPLIFIED. +!* +!* NOTE - +!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +! + INTEGER :: I,II,IM1,IZ,J,M,N,NM,NV +! + real(kind=8) :: A(NV),Z(NM,M) + real(kind=8) :: H,S !,DDOT +! + real(kind=8),PARAMETER :: ZERO = 0.0D+00 +! +!----------------------------------------------------------------------- +! + IF (M .EQ. 0) RETURN + IF (N .LE. 2) RETURN +! + II=3 + DO 140 I = 3, N + IZ=II+1 + II=II+I + H = A(II) + IF (H .EQ. ZERO) GO TO 140 + IM1 = I - 1 + DO 130 J = 1, M + S = -( DDOT(IM1,A(IZ),1,Z(1,J),1) * H) * H + CALL DAXPY(IM1,S,A(IZ),1,Z(1,J),1) + 130 CONTINUE + 140 CONTINUE + return + end subroutine ETRBK3 +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK ETRED3 + subroutine ETRED3(N,NV,A,D,E,E2) +!* +!* AUTHORS - +!* THIS IS A MODIFICATION OF ROUTINE TRED3 FROM EISPACK EDITION 3 +!* DATED AUGUST 1983. +!* EISPACK TRED3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, +!* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +!* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +!* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE JUN 1986 +!* +!* PURPOSE - +!* THIS ROUTINE REDUCES A REAL SYMMETRIC (PACKED) MATRIX, STORED +!* AS A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX +!* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS, PRESERVING THE +!* INFORMATION ABOUT THE TRANSFORMATIONS IN A. +!* +!* METHOD - +!* THE TRIDIAGONAL REDUCTION IS PERFORMED IN THE FOLLOWING WAY. +!* STARTING WITH J=N, THE ELEMENTS IN THE J-TH ROW TO THE +!* LEFT OF THE DIAGONAL ARE FIRST SCALED, TO AVOID POSSIBLE +!* UNDERFLOW IN THE TRANSFORMATION THAT MIGHT RESULT IN SEVERE +!* DEPARTURE FROM ORTHOGONALITY. THE SUM OF SQUARES SIGMA OF +!* THESE SCALED ELEMENTS IS NEXT FORMED. THEN, A VECTOR U AND +!* A SCALAR +!* H = U(TRANSPOSE) * U / 2 +!* DEFINE A REFLECTION OPERATOR +!* P = I - U * U(TRANSPOSE) / H +!* WHICH IS ORTHOGONAL AND SYMMETRIC AND FOR WHICH THE +!* SIMILIARITY TRANSFORMATION PAP ELIMINATES THE ELEMENTS IN +!* THE J-TH ROW OF A TO THE LEFT OF THE SUBDIAGONAL AND THE +!* SYMMETRICAL ELEMENTS IN THE J-TH COLUMN. +!* +!* THE NON-ZERO COMPONENTS OF U ARE THE ELEMENTS OF THE J-TH +!* ROW TO THE LEFT OF THE DIAGONAL WITH THE LAST OF THEM +!* AUGMENTED BY THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN +!* OF THE SUBDIAGONAL ELEMENT. BY STORING THE TRANSFORMED SUB- +!* DIAGONAL ELEMENT IN E(J) AND NOT OVERWRITING THE ROW +!* ELEMENTS ELIMINATED IN THE TRANSFORMATION, FULL INFORMATION +!* ABOUT P IS SAVE FOR LATER USE IN ETRBK3. +!* +!* THE TRANSFORMATION SETS E2(J) EQUAL TO SIGMA AND E(J) +!* EQUAL TO THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN +!* OF THE REPLACED SUBDIAGONAL ELEMENT. +!* +!* THE ABOVE STEPS ARE REPEATED ON FURTHER ROWS OF THE +!* TRANSFORMED A IN REVERSE ORDER UNTIL A IS REDUCED TO TRI- +!* DIAGONAL FORM, THAT IS, REPEATED FOR J = N-1,N-2,...,3. +!* +!* COMPLEXITY - +!* 2/3 N**3 +!* +!* ON ENTRY- +!* N - INTEGER +!* THE ORDER OF THE MATRIX. +!* NV - INTEGER +!* MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A +!* AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT +!* A - W.P. REAL (NV) +!* CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC +!* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL +!* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. +!* +!* ON EXIT- +!* A - W.P. REAL (NV) +!* CONTAINS INFORMATION ABOUT THE ORTHOGONAL +!* TRANSFORMATIONS USED IN THE REDUCTION. +!* D - W.P. REAL (N) +!* CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL +!* MATRIX. +!* E - W.P. REAL (N) +!* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +!* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO +!* E2 - W.P. REAL (N) +!* CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF +!* E. MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. +!* +!* DIFFERENCES FROM EISPACK 3 - +!* OUTER LOOP CHANGED FROM II=1,N TO I=N,3,-1 +!* PARAMETER STATEMENT AND GENERIC INTRINSIC FUNCTIONS USED +!* SCALE.NE.0 TEST NOW SPOTS TRI-DIAGONAL FORM +!* VALUES LESS THAN EPSLON CLEARED TO ZERO +!* USE BLAS(1) +!* U NOT COPIED TO D, LEFT IN A +!* E2 COMPUTED FROM E +!* INNER LOOPS SPLIT INTO ROUTINES ELAU AND FREDA +!* INVERSE OF H STORED INSTEAD OF H +!* +!* NOTE - +!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +! + INTEGER :: I,IIA,IZ0,L,N,NV +! + real(kind=8) :: A(NV),D(N),E2(N) + real(kind=8) :: E(*)!el E(L) + real(kind=8) :: AIIMAX,F,G,H,HROOT,SCALE,SCALEI +! real(kind=8) :: DASUM, DNRM2 +! + real(kind=8),PARAMETER :: ZERO = 0.0D+00, ONE = 1.0D+00 +! +!----------------------------------------------------------------------- +! + IF (N .LE. 2) GO TO 310 + IZ0 = (N*N+N)/2 + AIIMAX = ABS(A(IZ0)) + DO 300 I = N, 3, -1 + L = I - 1 + IIA = IZ0 + IZ0 = IZ0 - I + AIIMAX = MAX(AIIMAX, ABS(A(IIA))) + SCALE = DASUM (L, A(IZ0+1), 1) + IF(SCALE .EQ. ABS(A(IIA-1)) .OR. AIIMAX+SCALE .EQ. AIIMAX) THEN +! +! THIS ROW IS ALREADY IN TRI-DIAGONAL FORM +! + D(I) = A(IIA) + IF (AIIMAX+D(I) .EQ. AIIMAX) D(I) = ZERO + E(I) = A(IIA-1) + IF (AIIMAX+E(I) .EQ. AIIMAX) E(I) = ZERO + E2(I) = E(I)*E(I) + A(IIA) = ZERO + GO TO 300 +! + END IF +! + SCALEI = ONE / SCALE + CALL DSCAL(L,SCALEI,A(IZ0+1),1) + HROOT = DNRM2(L,A(IZ0+1),1) +! + F = A(IZ0+L) + G = -SIGN(HROOT,F) + E(I) = SCALE * G + E2(I) = E(I)*E(I) + H = HROOT*HROOT - F * G + A(IZ0+L) = F - G + D(I) = A(IIA) + A(IIA) = ONE / SQRT(H) +! .......... FORM P THEN Q IN E(1:L) .......... + CALL ELAU(ONE/H,L,A(IZ0+1),A,E) +! .......... FORM REDUCED A .......... + CALL FREDA(L,A(IZ0+1),A,E) +! + 300 CONTINUE + 310 CONTINUE + E(1) = ZERO + E2(1)= ZERO + D(1) = A(1) + IF(N.EQ.1) RETURN +! + E(2) = A(2) + E2(2)= A(2)*A(2) + D(2) = A(3) + return + end subroutine ETRED3 +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK EVVRSP + subroutine EVVRSP(MSGFL,N,NVECT,LENA,NV,A,B,IND,ROOT,VECT,IORDER,IERR) +!* +!* AUTHOR: S. T. ELBERT, AMES LABORATORY-USDOE, JUNE 1985 +!* +!* PURPOSE - +!* FINDS (ALL) EIGENVALUES AND (SOME OR ALL) EIGENVECTORS +!* * * * +!* OF A REAL SYMMETRIC PACKED MATRIX. +!* * * * +!* +!* METHOD - +!* THE METHOD AS PRESENTED IN THIS ROUTINE CONSISTS OF FOUR STEPS: +!* FIRST, THE INPUT MATRIX IS REDUCED TO TRIDIAGONAL FORM BY THE +!* HOUSEHOLDER TECHNIQUE (ORTHOGONAL SIMILARITY TRANSFORMATIONS). +!* SECOND, THE ROOTS ARE LOCATED USING THE RATIONAL QL METHOD. +!* THIRD, THE VECTORS OF THE TRIDIAGONAL FORM ARE EVALUATED BY THE +!* INVERSE ITERATION TECHNIQUE. VECTORS FOR DEGENERATE OR NEAR- +!* DEGENERATE ROOTS ARE FORCED TO BE ORTHOGONAL. +!* FOURTH, THE TRIDIAGONAL VECTORS ARE ROTATED TO VECTORS OF THE +!* ORIGINAL ARRAY. +!* +!* THESE ROUTINES ARE MODIFICATIONS OF THE EISPACK 3 +!* ROUTINES TRED3, TQLRAT, TINVIT AND TRBAK3 +!* +!* FOR FURTHER DETAILS, SEE EISPACK USERS GUIDE, B. T. SMITH +!* ET AL, SPRINGER-VERLAG, LECTURE NOTES IN COMPUTER SCIENCE, +!* VOL. 6, 2-ND EDITION, 1976. ANOTHER GOOD REFERENCE IS +!* THE SYMMETRIC EIGENVALUE PROBLEM BY B. N. PARLETT +!* PUBLISHED BY PRENTICE-HALL, INC., ENGLEWOOD CLIFFS, N.J. (1980) +!* +!* ON ENTRY - +!* MSGFL - INTEGER (LOGICAL UNIT NO.) +!* FILE WHERE ERROR MESSAGES WILL BE PRINTED. +!* IF MSGFL IS 0, ERROR MESSAGES WILL BE PRINTED ON LU 6. +!* IF MSGFL IS NEGATIVE, NO ERROR MESSAGES PRINTED. +!* N - INTEGER +!* ORDER OF MATRIX A. +!* NVECT - INTEGER +!* NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N. +!* LENA - INTEGER +!* DIMENSION OF A IN CALLING ROUTINE. MUST NOT BE LESS +!* THAN (N*N+N)/2. +!* NV - INTEGER +!* ROW DIMENSION OF VECT IN CALLING ROUTINE. N .LE. NV. +!* A - WORKING PRECISION REAL (LENA) +!* INPUT MATRIX, ROWS OF THE LOWER TRIANGLE PACKED INTO +!* LINEAR ARRAY OF DIMENSION N*(N+1)/2. THE PACKED ORDER +!* IS A(1,1), A(2,1), A(2,2), A(3,1), A(3,2), ... +!* B - WORKING PRECISION REAL (N,8) +!* SCRATCH ARRAY, 8*N ELEMENTS +!* IND - INTEGER (N) +!* SCRATCH ARRAY OF LENGTH N. +!* IORDER - INTEGER +!* ROOT ORDERING FLAG. +!* = 0, ROOTS WILL BE PUT IN ASCENDING ORDER. +!* = 2, ROOTS WILL BE PUT IN DESCENDING ORDER. +!* +!* ON EXIT - +!* A - DESTORYED. NOW HOLDS REFLECTION OPERATORS. +!* ROOT - WORKING PRECISION REAL (N) +!* ALL EIGENVALUES IN ASCENDING OR DESCENDING ORDER. +!* IF IORDER = 0, ROOT(1) .LE. ... .LE. ROOT(N) +!* IF IORDER = 2, ROOT(1) .GE. ... .GE. ROOT(N) +!* VECT - WORKING PRECISION REAL (NV,NVECT) +!* EIGENVECTORS FOR ROOT(1), ..., ROOT(NVECT). +!* IERR - INTEGER +!* = 0 IF NO ERROR DETECTED, +!* = K IF ITERATION FOR K-TH EIGENVALUE FAILED, +!* = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. +!* (FAILURES SHOULD BE VERY RARE. CONTACT C. MOLER.) +!* +! + use comm_par +!el LOGICAL :: GOPARR,DSKWRK,MASWRK +! + integer :: MSGFL,N,NVECT,LENA,NV,IORDER,IERR + real(kind=8) :: A(LENA) + real(kind=8) :: B(N,8) + real(kind=8) :: ROOT(N) + real(kind=8) :: T + real(kind=8) :: VECT(NV,*) +! + INTEGER :: IND(N) +! +!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM + real(kind=8) :: DSKW + +!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +! + 900 FORMAT(26H0*** EVVRSP PARAMETERS ***/ & + 14H *** N = ,I8,4H ***/ & + 14H *** NVECT = ,I8,4H ***/ & + 14H *** LENA = ,I8,4H ***/ & + 14H *** NV = ,I8,4H ***/ & + 14H *** IORDER = ,I8,4H ***/ & + 14H *** IERR = ,I8,4H ***) + 901 FORMAT(37H VALUE OF LENA IS LESS THAN (N*N+N)/2) + 902 FORMAT(39H EQLRAT HAS FAILED TO CONVERGE FOR ROOT,I5) + 903 FORMAT(18H NV IS LESS THAN N) + 904 FORMAT(41H EINVIT HAS FAILED TO CONVERGE FOR VECTOR,I5) + 905 FORMAT(51H VALUE OF IORDER MUST BE 0 (SMALLEST ROOT FIRST) OR & + ,23H 2 (LARGEST ROOT FIRST)) + 906 FORMAT(' VALUE OF N IS LESS THAN OR EQUAL ZERO') + + integer :: LMSGFL,I,J,L,JSV,KLIM,K +! +!----------------------------------------------------------------------- +! + LMSGFL=MSGFL + IF (MSGFL .EQ. 0) LMSGFL=6 + IERR = N - 1 + IF (N .LE. 0) GO TO 800 + IERR = N + 1 + IF ( (N*N+N)/2 .GT. LENA) GO TO 810 +! +! REDUCE REAL SYMMETRIC MATRIX A TO TRIDIAGONAL FORM +! + CALL ETRED3(N,LENA,A,B(1,1),B(1,2),B(1,3)) +! +! FIND ALL EIGENVALUES OF TRIDIAGONAL MATRIX +! + CALL EQLRAT(N,B(1,1),B(1,2),B(1,3),ROOT,IND,IERR,B(1,4)) + IF (IERR .NE. 0) GO TO 820 +! +! CHECK THE DESIRED ORDER OF THE EIGENVALUES +! + B(1,3) = IORDER + IF (IORDER .EQ. 0) GO TO 300 + IF (IORDER .NE. 2) GO TO 850 +! +! ORDER ROOTS IN DESCENDING ORDER (LARGEST FIRST)... +! TURN ROOT AND IND ARRAYS END FOR END +! + DO 210 I = 1, N/2 + J = N+1-I + T = ROOT(I) + ROOT(I) = ROOT(J) + ROOT(J) = T + L = IND(I) + IND(I) = IND(J) + IND(J) = L + 210 CONTINUE +! +! FIND I AND J MARKING THE START AND END OF A SEQUENCE +! OF DEGENERATE ROOTS +! + I=0 + 220 CONTINUE + I = I+1 + IF (I .GT. N) GO TO 300 + DO 230 J=I,N + IF (ROOT(J) .NE. ROOT(I)) GO TO 240 + 230 CONTINUE + J = N+1 + 240 CONTINUE + J = J-1 + IF (J .EQ. I) GO TO 220 +! +! TURN AROUND IND BETWEEN I AND J +! + JSV = J + KLIM = (J-I+1)/2 + DO 250 K=1,KLIM + L = IND(J) + IND(J) = IND(I) + IND(I) = L + I = I+1 + J = J-1 + 250 CONTINUE + I = JSV + GO TO 220 +! + 300 CONTINUE +! + IF (NVECT .LE. 0) RETURN + IF (NV .LT. N) GO TO 830 +! +! FIND EIGENVECTORS OF TRI-DIAGONAL MATRIX VIA INVERSE ITERATION +! + IERR = LMSGFL + CALL EINVIT(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,IND,& + VECT,IERR,B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) + IF (IERR .NE. 0) GO TO 840 +! +! FIND EIGENVECTORS OF SYMMETRIC MATRIX VIA BACK TRANSFORMATION +! + 400 CONTINUE + CALL ETRBK3(NV,N,LENA,A,NVECT,VECT) + RETURN +! +! ERROR MESSAGE SECTION +! + 800 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,906) + GO TO 890 +! + 810 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,901) + GO TO 890 +! + 820 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,902) IERR + GO TO 890 +! + 830 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,903) + GO TO 890 +! + 840 CONTINUE + IF ((LMSGFL .GT. 0).AND.MASWRK) WRITE(LMSGFL,904) -IERR + GO TO 400 +! + 850 IERR=-1 + IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,905) + GO TO 890 +! + 890 CONTINUE + IF (MASWRK) WRITE(LMSGFL,900) N,NVECT,LENA,NV,IORDER,IERR + return + end subroutine EVVRSP +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK FREDA + subroutine FREDA(L,D,A,E) +! + integer :: l,jk,j,k + real(kind=8) :: A(*) + real(kind=8) :: D(L) + real(kind=8) :: E(*)!el E(L) + real(kind=8) :: F + real(kind=8) :: G +! + JK = 1 +! +! .......... FORM REDUCED A .......... +! + DO 280 J = 1, L + F = D(J) + G = E(J) +! + DO 260 K = 1, J + A(JK) = A(JK) - F * E(K) - G * D(K) + JK = JK + 1 + 260 CONTINUE +! + 280 CONTINUE + return + end subroutine FREDA +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK GIVEIS + subroutine GIVEIS(N,NVECT,NV,A,B,INDB,ROOT,VECT,IERR) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,NVECT,NV,IERR + real(kind=8),DIMENSION(*) :: A + real(kind=8),DIMENSION(N,8) :: B + integer,DIMENSION(N) :: INDB + real(kind=8),DIMENSION(N) :: ROOT + real(kind=8),DIMENSION(NV,NVECT) :: VECT +! +! EISPACK-BASED SUBSTITUTE FOR QCPE ROUTINE GIVENS. +! FINDS ALL EIGENVALUES AND SOME EIGENVECTORS OF A REAL SYMMETRIC +! MATRIX. AUTHOR.. C. MOLER AND D. SPANGLER, N.R.C.C., 4/1/79. +! +! INPUT.. +! N = ORDER OF MATRIX . +! NVECT = NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N . +! NV = LEADING DIMENSION OF VECT . +! A = INPUT MATRIX, COLUMNS OF THE UPPER TRIANGLE PACKED INTO +! LINEAR ARRAY OF DIMENSION N*(N+1)/2 . +! B = SCRATCH ARRAY, 8*N ELEMENTS (NOTE THIS IS MORE THAN +! PREVIOUS VERSIONS OF GIVENS.) +! IND = INDEX ARRAY OF N ELEMENTS +! +! OUTPUT.. +! A DESTROYED . +! ROOT = ALL EIGENVALUES, ROOT(1) .LE. ... .LE. ROOT(N) . +! (FOR OTHER ORDERINGS, SEE BELOW.) +! VECT = EIGENVECTORS FOR ROOT(1),..., ROOT(NVECT) . +! IERR = 0 IF NO ERROR DETECTED, +! = K IF ITERATION FOR K-TH EIGENVALUE FAILED, +! = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. +! (FAILURES SHOULD BE VERY RARE. CONTACT MOLER.) +! +! CALLS MODIFIED EISPACK ROUTINES TRED3B, IMTQLV, TINVTB, AND +! TRBK3B. THE ROUTINES TRED3B, TINVTB, AND TRBK3B. +! THE ORIGINAL EISPACK ROUTINES TRED3, TINVIT, AND TRBAK3 +! WERE MODIFIED BY THE INTRODUCTION OF TWO ROUTINES FROM THE +! BLAS LIBRARY - DDOT AND DAXPY. +! +! IF TINVIT FAILS TO CONVERGE, TQL2 IS CALLED +! +! SEE EISPACK USERS GUIDE, B. T. SMITH ET AL, SPRINGER-VERLAG +! LECTURE NOTES IN COMPUTER SCIENCE, VOL. 6, 2-ND EDITION, 1976 . +! NOTE THAT IMTQLV AND TINVTB HAVE INTERNAL MACHINE +! DEPENDENT CONSTANTS. +! +!el DATA ONE, ZERO /1.0D+00, 0.0D+00/ + real(kind=8) :: ZERO = 0.0D+00, ONE = 1.0D+00 + + integer :: i,j + + CALL TRED3B(N,(N*N+N)/2,A,B(1,1),B(1,2),B(1,3)) + CALL IMTQLV(N,B(1,1),B(1,2),B(1,3),ROOT,INDB,IERR,B(1,4)) + IF (IERR .NE. 0) RETURN +! +! TO REORDER ROOTS... +! K = N/2 +! B(1,3) = 2.0D+00 +! DO 50 I = 1, K +! J = N+1-I +! T = ROOT(I) +! ROOT(I) = ROOT(J) +! ROOT(J) = T +! 50 CONTINUE +! + IF (NVECT .LE. 0) RETURN + CALL TINVTB(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,INDB,VECT,IERR,& + B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) + IF (IERR .EQ. 0) GO TO 160 +! +! IF INVERSE ITERATION GIVES AN ERROR IN DETERMINING THE +! EIGENVECTORS, TRY THE QL ALGORITHM IF ALL THE EIGENVECTORS +! ARE DESIRED. +! + IF (NVECT .NE. N) RETURN + DO 120 I = 1, NVECT + DO 100 J = 1, N + VECT(I,J) = ZERO + 100 CONTINUE + VECT(I,I) = ONE + 120 CONTINUE + CALL TQL2 (NV,N,B(1,1),B(1,2),VECT,IERR) + DO 140 I = 1, NVECT + ROOT(I) = B(I,1) + 140 CONTINUE + IF (IERR .NE. 0) RETURN + 160 CALL TRBK3B(NV,N,(N*N+N)/2,A,NVECT,VECT) + return + end subroutine GIVEIS +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK GLDIAG + subroutine GLDIAG(LDVECT,NVECT,N,H,WRK,EIG,VECTOR,IERR,IWRK) +! +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! + use comm_iofile + use comm_machsw + use comm_par +!el LOGICAL :: GOPARR,DSKWRK,MASWRK +! + integer :: LDVECT,NVECT,N,IERR + real(kind=8),DIMENSION(*) :: H + real(kind=8),DIMENSION(N,8) :: WRK + real(kind=8),DIMENSION(N) :: EIG + integer,DIMENSION(N) :: IWRK + real(kind=8),DIMENSION(LDVECT,NVECT) :: VECTOR +! +!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 +!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM +!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +! + integer :: LENH,KORDER + +! ----- GENERAL ROUTINE TO DIAGONALIZE A SYMMETRIC MATRIX ----- +! IF KDIAG = 0, USE A ROUTINE FROM THE VECTOR LIBRARY, +! IF AVAILABLE (SEE THE SUBROUTINE 'GLDIAG' +! IN VECTOR.SRC), OR EVVRSP OTHERWISE +! = 1, USE EVVRSP +! = 2, USE GIVEIS +! = 3, USE JACOBI +! +! N = DIMENSION (ORDER) OF MATRIX TO BE SOLVED +! LDVECT = LEADING DIMENSION OF VECTOR +! NVECT = NUMBER OF VECTORS DESIRED +! H = MATRIX TO BE DIAGONALIZED +! WRK = N*8 W.P. REAL WORDS OF SCRATCH SPACE +! EIG = EIGENVECTORS (OUTPUT) +! VECTOR = EIGENVECTORS (OUTPUT) +! IERR = ERROR FLAG (OUTPUT) +! IWRK = N INTEGER WORDS OF SCRATCH SPACE +! + IERR = 0 +! +! ----- USE STEVE ELBERT'S ROUTINE ----- +! + IF(KDIAG.LE.1 .OR. KDIAG.GT.3) THEN + LENH = (N*N+N)/2 + KORDER =0 + CALL EVVRSP(IW,N,NVECT,LENH,LDVECT,H,WRK,IWRK,EIG,VECTOR, & + KORDER,IERR) + END IF +! +! ----- USE MODIFIED EISPAK ROUTINE ----- +! + IF(KDIAG.EQ.2) & + CALL GIVEIS(N,NVECT,LDVECT,H,WRK,IWRK,EIG,VECTOR,IERR) +! +! ----- USE JACOBI ROTATION ROUTINE ----- +! + IF(KDIAG.EQ.3) THEN + IF(NVECT.EQ.N) THEN + CALL JACDG(H,VECTOR,EIG,IWRK,WRK,LDVECT,N) + ELSE + IF (MASWRK) WRITE(IW,9000) N,NVECT,LDVECT + CALL ABRT + END IF + END IF + RETURN +! + 9000 FORMAT(1X,'IN -GLDIAG-, N,NVECT,LDVECT=',3I8/ & + 1X,'THE JACOBI CODE CANNOT COPE WITH N.NE.NVECT!'/ & + 1X,'SO THIS RUN DOES NOT PERMIT KDIAG=3.') + end subroutine GLDIAG +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK IMTQLV + subroutine IMTQLV(N,D,E,E2,W,IND,IERR,RV1) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + INTEGER :: N,TAG,IERR + real(kind=8) :: MACHEP + real(kind=8),DIMENSION(N) :: D,E2,W,RV1 + real(kind=8) :: E(*)!el E(L) + integer,DIMENSION(N) :: IND + integer :: k,i,l,j,m,mml,ii + real(kind=8) :: c,p,s,f,b,g,r +! +! THIS ROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF +! ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND +! WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. +! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). +! +! THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL +! MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM +! THEIR CORRESPONDING SUBMATRIX INDICES. +! +! ON INPUT- +! +! N IS THE ORDER OF THE MATRIX, +! +! D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, +! +! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +! IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, +! +! E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. +! E2(1) IS ARBITRARY. +! +! ON OUTPUT- +! +! D AND E ARE UNALTERED, +! +! ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED +! AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE +! MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. +! E2(1) IS ALSO SET TO ZERO, +! +! W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +! ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND +! ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE +! THE SMALLEST EIGENVALUES, +! +! IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE +! CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES +! BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, +! 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC., +! +! IERR IS SET TO +! ZERO FOR NORMAL RETURN, +! J IF THE J-TH EIGENVALUE HAS NOT BEEN +! DETERMINED AFTER 30 ITERATIONS, +! +! RV1 IS A TEMPORARY STORAGE ARRAY. +! +! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +! +! ------------------------------------------------------------------ +! +! ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING +! THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +! +! ********** + MACHEP = 2.0D+00**(-50) +! + IERR = 0 + K = 0 + TAG = 0 +! + DO 100 I = 1, N + W(I) = D(I) + IF (I .NE. 1) RV1(I-1) = E(I) + 100 CONTINUE +! + E2(1) = 0.0D+00 + RV1(N) = 0.0D+00 +! + DO 360 L = 1, N + J = 0 +! ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** + 120 DO 140 M = L, N + IF (M .EQ. N) GO TO 160 + IF (ABS(RV1(M)) .LE. MACHEP * (ABS(W(M)) + ABS(W(M+1)))) GO TO & + 160 +! ********** GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ********** + IF (E2(M+1) .EQ. 0.0D+00) GO TO 180 + 140 CONTINUE +! + 160 IF (M .LE. K) GO TO 200 + IF (M .NE. N) E2(M+1) = 0.0D+00 + 180 K = M + TAG = TAG + 1 + 200 P = W(L) + IF (M .EQ. L) GO TO 280 + IF (J .EQ. 30) GO TO 380 + J = J + 1 +! ********** FORM SHIFT ********** + G = (W(L+1) - P) / (2.0D+00 * RV1(L)) + R = SQRT(G*G+1.0D+00) + G = W(M) - P + RV1(L) / (G + SIGN(R,G)) + S = 1.0D+00 + C = 1.0D+00 + P = 0.0D+00 + MML = M - L +! ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** + DO 260 II = 1, MML + I = M - II + F = S * RV1(I) + B = C * RV1(I) + IF (ABS(F) .LT. ABS(G)) GO TO 220 + C = G / F + R = SQRT(C*C+1.0D+00) + RV1(I+1) = F * R + S = 1.0D+00 / R + C = C * S + GO TO 240 + 220 S = F / G + R = SQRT(S*S+1.0D+00) + RV1(I+1) = G * R + C = 1.0D+00 / R + S = S * C + 240 G = W(I+1) - P + R = (W(I) - G) * S + 2.0D+00 * C * B + P = S * R + W(I+1) = G + P + G = C * R - B + 260 CONTINUE +! + W(L) = W(L) - P + RV1(L) = G + RV1(M) = 0.0D+00 + GO TO 120 +! ********** ORDER EIGENVALUES ********** + 280 IF (L .EQ. 1) GO TO 320 +! ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** + DO 300 II = 2, L + I = L + 2 - II + IF (P .GE. W(I-1)) GO TO 340 + W(I) = W(I-1) + IND(I) = IND(I-1) + 300 CONTINUE +! + 320 I = 1 + 340 W(I) = P + IND(I) = TAG + 360 CONTINUE +! + GO TO 400 +! ********** SET ERROR -- NO CONVERGENCE TO AN +! EIGENVALUE AFTER 30 ITERATIONS ********** + 380 IERR = L + 400 return +! ********** LAST CARD OF IMTQLV ********** + end subroutine IMTQLV +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK JACDG + subroutine JACDG(A,VEC,EIG,JBIG,BIG,LDVEC,N) +! +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) +! + integer :: LDVEC,N + real(kind=8),DIMENSION(*) :: A + real(kind=8),DIMENSION(LDVEC,N) :: VEC + real(kind=8),DIMENSION(N) :: EIG,BIG + integer,DIMENSION(N) :: JBIG +! + real(kind=8),PARAMETER :: ONE=1.0D+00 + integer :: i,NB1,NB2,NMIN,NMAX +! +! ----- JACOBI DIAGONALIZATION OF SYMMETRIC MATRIX ----- +! SYMMETRIC MATRIX -A- OF DIMENSION -N- IS DESTROYED ON EXIT. +! ALL EIGENVECTORS ARE FOUND, SO -VEC- MUST BE SQUARE, +! UNLESS SOMEONE TAKES THE TROUBLE TO LOOK AT -NMAX- BELOW. +! -BIG- AND -JBIG- ARE SCRATCH WORK ARRAYS. +! + CALL VCLR(VEC,1,LDVEC*N) + DO 20 I = 1,N + VEC(I,I) = ONE + 20 CONTINUE +! + NB1 = N + NB2 = (NB1*NB1+NB1)/2 + NMIN = 1 + NMAX = NB1 +! + CALL JACDIA(A,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) +! + DO 30 I=1,N + EIG(I) = A((I*I+I)/2) + 30 CONTINUE +! + CALL JACORD(VEC,EIG,NB1,LDVEC) + return + end subroutine JACDG +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK JACDIA + subroutine JACDIA(F,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + use comm_par + integer :: NB1,NB2,LDVEC,NMIN,NMAX +!el LOGICAL :: GOPARR,DSKWRK,MASWRK + real(kind=8),DIMENSION(NB2) :: F + real(kind=8),DIMENSION(LDVEC,NB1) :: VEC + real(kind=8),DIMENSION(NB1) :: BIG + integer,DIMENSION(NB1) :: JBIG +! +!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM +!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +! + real(kind=8),PARAMETER :: ROOT2=0.707106781186548D+00 + real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00, D1050=1.05D+00,& + D1500=1.5D+00, D3875=3.875D+00,& + D0500=0.5D+00, D1375=1.375D+00, D0250=0.25D+00 + real(kind=8),PARAMETER :: C2=1.0D-12, C3=4.0D-16,& + C4=2.0D-16, C5=8.0D-09, C6=3.0D-06 + integer :: i,ii,j,k,jj,IEAA,IEAB,MAXIT,ITER,I1,IA,IB,IAA,IBB,IEAR,& + IEBR,IR,IT,KQ,IR1 + real(kind=8) :: T,TT,EPS,SD,TEST,DIF,CX,SX,T2X2,T2X25,T1,T2 +! +! F IS THE MATRIX TO BE DIAGONALIZED, F IS STORED TRIANGULAR +! VEC IS THE ARRAY OF EIGENVECTORS, DIMENSION NB1*NB1 +! BIG AND JBIG ARE TEMPORARY SCRATCH AREAS OF DIMENSION NB1 +! THE ROTATIONS AMONG THE FIRST NMIN BASIS FUNCTIONS ARE NOT +! ACCOUNTED FOR. +! THE ROTATIONS AMONG THE LAST NB1-NMAX BASIS FUNCTIONS ARE NOT +! ACCOUNTED FOR. +! + IEAA=0 + IEAB=0 + TT=ZERO + EPS = 64.0D+00*EPSLON(ONE) +! +! LOOP OVER COLUMNS (K) OF TRIANGULAR MATRIX TO DETERMINE +! LARGEST OFF-DIAGONAL ELEMENTS IN ROW(I). +! + DO 20 I=1,NB1 + BIG(I)=ZERO + JBIG(I)=0 + IF(I.LT.NMIN .OR. I.EQ.1) GO TO 20 + II = (I*I-I)/2 + J=MIN(I-1,NMAX) + DO 10 K=1,J + IF(ABS(BIG(I)).GE.ABS(F(II+K))) GO TO 10 + BIG(I)=F(II+K) + JBIG(I)=K + 10 CONTINUE + 20 CONTINUE +! +! ----- 2X2 JACOBI ITERATIONS BEGIN HERE ----- +! + MAXIT=MAX(NB2*20,500) + ITER=0 + 30 CONTINUE + ITER=ITER+1 +! +! FIND SMALLEST DIAGONAL ELEMENT +! + SD=D1050 + JJ=0 + DO 40 J=1,NB1 + JJ=JJ+J + SD= MIN(SD,ABS(F(JJ))) + 40 CONTINUE + TEST = MAX(EPS, C2*MAX(SD,C6)) +! +! FIND LARGEST OFF-DIAGONAL ELEMENT +! + T=ZERO + I1=MAX(2,NMIN) + IB = I1 + DO 50 I=I1,NB1 + IF(T.GE.ABS(BIG(I))) GO TO 50 + T= ABS(BIG(I)) + IB=I + 50 CONTINUE +! +! TEST FOR CONVERGENCE, THEN DETERMINE ROTATION. +! + IF(T.LT.TEST) RETURN +! ****** +! + IF(ITER.GT.MAXIT) THEN + IF (MASWRK) THEN + WRITE(6,*) 'JACOBI DIAGONALIZATION FAILS, DIMENSION=',NB1 + WRITE(6,9020) ITER,T,TEST,SD + ENDIF + CALL ABRT + STOP + END IF +! + IA=JBIG(IB) + IAA=IA*(IA-1)/2 + IBB=IB*(IB-1)/2 + DIF=F(IAA+IA)-F(IBB+IB) + IF(ABS(DIF).GT.C3*T) GO TO 70 + SX=ROOT2 + CX=ROOT2 + GO TO 110 + 70 T2X2=BIG(IB)/DIF + T2X25=T2X2*T2X2 + IF(T2X25 .GT. C4) GO TO 80 + CX=ONE + SX=T2X2 + GO TO 110 + 80 IF(T2X25 .GT. C5) GO TO 90 + SX=T2X2*(ONE-D1500*T2X25) + CX=ONE-D0500*T2X25 + GO TO 110 + 90 IF(T2X25 .GT. C6) GO TO 100 + CX=ONE+T2X25*(T2X25*D1375 - D0500) + SX= T2X2*(ONE + T2X25*(T2X25*D3875 - D1500)) + GO TO 110 + 100 T=D0250 / SQRT(D0250 + T2X25) + CX= SQRT(D0500 + T) + SX= SIGN( SQRT(D0500 - T),T2X2) + 110 IEAR=IAA+1 + IEBR=IBB+1 +! + DO 230 IR=1,NB1 + T=F(IEAR)*SX + F(IEAR)=F(IEAR)*CX+F(IEBR)*SX + F(IEBR)=T-F(IEBR)*CX + IF(IR-IA) 220,120,130 + 120 TT=F(IEBR) + IEAA=IEAR + IEAB=IEBR + F(IEBR)=BIG(IB) + IEAR=IEAR+IR-1 + IF(JBIG(IR)) 200,220,200 + 130 T=F(IEAR) + IT=IA + IEAR=IEAR+IR-1 + IF(IR-IB) 180,150,160 + 150 F(IEAA)=F(IEAA)*CX+F(IEAB)*SX + F(IEAB)=TT*CX+F(IEBR)*SX + F(IEBR)=TT*SX-F(IEBR)*CX + IEBR=IEBR+IR-1 + GO TO 200 + 160 IF( ABS(T) .GE. ABS(F(IEBR))) GO TO 170 + IF(IB.GT.NMAX) GO TO 170 + T=F(IEBR) + IT=IB + 170 IEBR=IEBR+IR-1 + 180 IF( ABS(T) .LT. ABS(BIG(IR))) GO TO 190 + BIG(IR) = T + JBIG(IR) = IT + GO TO 220 + 190 IF(IA .NE. JBIG(IR) .AND. IB .NE. JBIG(IR)) GO TO 220 + 200 KQ=IEAR-IR-IA+1 + BIG(IR)=ZERO + IR1=MIN(IR-1,NMAX) + DO 210 I=1,IR1 + K=KQ+I + IF(ABS(BIG(IR)) .GE. ABS(F(K))) GO TO 210 + BIG(IR) = F(K) + JBIG(IR)=I + 210 CONTINUE + 220 IEAR=IEAR+1 + 230 IEBR=IEBR+1 +! + DO 240 I=1,NB1 + T1=VEC(I,IA)*CX + VEC(I,IB)*SX + T2=VEC(I,IA)*SX - VEC(I,IB)*CX + VEC(I,IA)=T1 + VEC(I,IB)=T2 + 240 CONTINUE + GO TO 30 +! + 9020 FORMAT(1X,'ITER=',I6,' T,TEST,SD=',1P,3E20.10) + end subroutine JACDIA +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK JACORD + subroutine JACORD(VEC,EIG,N,LDVEC) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,LDVEC + real(kind=8),DIMENSION(LDVEC,N) :: VEC + real(kind=8),DIMENSION(N) :: EIG + integer :: i,jj,j + real(kind=8) :: T +! +! ---- SORT EIGENDATA INTO ASCENDING ORDER ----- +! + DO 290 I = 1, N + JJ = I + DO 270 J = I, N + IF (EIG(J) .LT. EIG(JJ)) JJ = J + 270 CONTINUE + IF (JJ .EQ. I) GO TO 290 + T = EIG(JJ) + EIG(JJ) = EIG(I) + EIG(I) = T + DO 280 J = 1, N + T = VEC(J,JJ) + VEC(J,JJ) = VEC(J,I) + VEC(J,I) = T + 280 CONTINUE + 290 CONTINUE + return + end subroutine JACORD +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK TINVTB + subroutine TINVTB(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: NM,N,M,IERR + real(kind=8),DIMENSION(N) :: D,E,E2 + real(kind=8),DIMENSION(M) :: W + real(kind=8),DIMENSION(NM,M) :: Z + real(kind=8),DIMENSION(N) :: RV1,RV2,RV3,RV4,RV6 + integer,DIMENSION(M) :: IND + real(kind=8) :: MACHEP,NORM + INTEGER :: P,Q,R,S,TAG,GROUP + integer :: ii,j,jj,i,iqmp,its + real(kind=8) :: ORDER,XU,UK,X0,U,EPS2,EPS3,EPS4,x1,v + +! ------------------------------------------------------------------ +! +! THIS ROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- +! NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. +! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). +! +! THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL +! SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, +! USING INVERSE ITERATION. +! +! ON INPUT- +! +! NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +! ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +! DIMENSION STATEMENT, +! +! N IS THE ORDER OF THE MATRIX, +! +! D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, +! +! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +! IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, +! +! E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, +! WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. +! E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN +! THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM +! OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN +! 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0 +! IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, +! TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, +! THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE, +! +! M IS THE NUMBER OF SPECIFIED EIGENVALUES, +! +! W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER, +! +! IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES +! ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- +! 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM +! THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. +! +! ON OUTPUT- +! +! ALL INPUT ARRAYS ARE UNALTERED, +! +! Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. +! ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO, +! +! IERR IS SET TO +! ZERO FOR NORMAL RETURN, +! -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH +! EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS, +! +! RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. +! +! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +! +! ------------------------------------------------------------------ +! +! ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING +! THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +! +! ********** + MACHEP = 2.0D+00**(-50) +! + IERR = 0 + IF (M .EQ. 0) GO TO 680 + TAG = 0 + ORDER = 1.0D+00 - E2(1) + XU = 0.0D+00 + UK = 0.0D+00 + X0 = 0.0D+00 + U = 0.0D+00 + EPS2 = 0.0D+00 + EPS3 = 0.0D+00 + EPS4 = 0.0D+00 + GROUP = 0 + Q = 0 +! ********** ESTABLISH AND PROCESS NEXT SUBMATRIX ********** + 100 P = Q + 1 + IP = P + 1 +! + DO 120 Q = P, N + IF (Q .EQ. N) GO TO 140 + IF (E2(Q+1) .EQ. 0.0D+00) GO TO 140 + 120 CONTINUE +! ********** FIND VECTORS BY INVERSE ITERATION ********** + 140 TAG = TAG + 1 + IQMP = Q - P + 1 + S = 0 +! + DO 660 R = 1, M + IF (IND(R) .NE. TAG) GO TO 660 + ITS = 1 + X1 = W(R) + IF (S .NE. 0) GO TO 220 +! ********** CHECK FOR ISOLATED ROOT ********** + XU = 1.0D+00 + IF (P .NE. Q) GO TO 160 + RV6(P) = 1.0D+00 + GO TO 600 + 160 NORM = ABS(D(P)) +! + DO 180 I = IP, Q + 180 NORM = NORM + ABS(D(I)) + ABS(E(I)) +! ********** EPS2 IS THE CRITERION FOR GROUPING, +! EPS3 REPLACES ZERO PIVOTS AND EQUAL +! ROOTS ARE MODIFIED BY EPS3, +! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ********** + EPS2 = 1.0D-03 * NORM + EPS3 = MACHEP * NORM + UK = IQMP + EPS4 = UK * EPS3 + UK = EPS4 / SQRT(UK) + S = P + 200 GROUP = 0 + GO TO 240 +! ********** LOOK FOR CLOSE OR COINCIDENT ROOTS ********** + 220 IF (ABS(X1-X0) .GE. EPS2) GO TO 200 + GROUP = GROUP + 1 + IF (ORDER * (X1 - X0) .LE. 0.0D+00) X1 = X0 + ORDER * EPS3 +! ********** ELIMINATION WITH INTERCHANGES AND +! INITIALIZATION OF VECTOR ********** + 240 V = 0.0D+00 +! + DO 300 I = P, Q + RV6(I) = UK + IF (I .EQ. P) GO TO 280 + IF (ABS(E(I)) .LT. ABS(U)) GO TO 260 +! ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF +! E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ********** + XU = U / E(I) + RV4(I) = XU + RV1(I-1) = E(I) + RV2(I-1) = D(I) - X1 + RV3(I-1) = 0.0D+00 + IF (I .NE. Q) RV3(I-1) = E(I+1) + U = V - XU * RV2(I-1) + V = -XU * RV3(I-1) + GO TO 300 + 260 XU = E(I) / U + RV4(I) = XU + RV1(I-1) = U + RV2(I-1) = V + RV3(I-1) = 0.0D+00 + 280 U = D(I) - X1 - XU * V + IF (I .NE. Q) V = E(I+1) + 300 CONTINUE +! + IF (U .EQ. 0.0D+00) U = EPS3 + RV1(Q) = U + RV2(Q) = 0.0D+00 + RV3(Q) = 0.0D+00 +! ********** BACK SUBSTITUTION +! FOR I=Q STEP -1 UNTIL P DO -- ********** + 320 DO 340 II = P, Q + I = P + Q - II + RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) + V = U + U = RV6(I) + 340 CONTINUE +! ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS +! MEMBERS OF GROUP ********** + IF (GROUP .EQ. 0) GO TO 400 + J = R +! + DO 380 JJ = 1, GROUP + 360 J = J - 1 + IF (IND(J) .NE. TAG) GO TO 360 + XU = DDOT(IQMP,RV6(P),1,Z(P,J),1) +! + CALL DAXPY(IQMP,-XU,Z(P,J),1,RV6(P),1) +! + 380 CONTINUE +! + 400 NORM = 0.0D+00 +! + DO 420 I = P, Q + 420 NORM = NORM + ABS(RV6(I)) +! + IF (NORM .GE. 1.0D+00) GO TO 560 +! ********** FORWARD SUBSTITUTION ********** + IF (ITS .EQ. 5) GO TO 540 + IF (NORM .NE. 0.0D+00) GO TO 440 + RV6(S) = EPS4 + S = S + 1 + IF (S .GT. Q) S = P + GO TO 480 + 440 XU = EPS4 / NORM +! + DO 460 I = P, Q + 460 RV6(I) = RV6(I) * XU +! ********** ELIMINATION OPERATIONS ON NEXT VECTOR +! ITERATE ********** + 480 DO 520 I = IP, Q + U = RV6(I) +! ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE +! WAS PERFORMED EARLIER IN THE +! TRIANGULARIZATION PROCESS ********** + IF (RV1(I-1) .NE. E(I)) GO TO 500 + U = RV6(I-1) + RV6(I-1) = RV6(I) + 500 RV6(I) = U - RV4(I) * RV6(I-1) + 520 CONTINUE +! + ITS = ITS + 1 + GO TO 320 +! ********** SET ERROR -- NON-CONVERGED EIGENVECTOR ********** + 540 IERR = -R + XU = 0.0D+00 + GO TO 600 +! ********** NORMALIZE SO THAT SUM OF SQUARES IS +! 1 AND EXPAND TO FULL ORDER ********** + 560 U = 0.0D+00 +! + DO 580 I = P, Q + RV6(I) = RV6(I) / NORM + 580 U = U + RV6(I)**2 +! + XU = 1.0D+00 / SQRT(U) +! + 600 DO 620 I = 1, N + 620 Z(I,R) = 0.0D+00 +! + DO 640 I = P, Q + 640 Z(I,R) = RV6(I) * XU +! + X0 = X1 + 660 CONTINUE +! + IF (Q .LT. N) GO TO 100 + 680 return +! ********** LAST CARD OF TINVIT ********** + end subroutine TINVTB +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK TQL2 + subroutine TQL2(NM,N,D,E,Z,IERR) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: NM,N,IERR + real(kind=8) :: MACHEP + real(kind=8),DIMENSION(N) :: D!,E + real(kind=8) :: E(*)!el E(L) + real(kind=8),DIMENSION(NM,N) :: Z + integer :: ii,i,j,mml,m,l1,k,l + real(kind=8) :: c,f,b,h,g,p,r,s +! +! THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, +! NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND +! WILKINSON. +! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). +! +! THIS ROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS +! OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. +! THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO +! BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS +! FULL MATRIX TO TRIDIAGONAL FORM. +! +! ON INPUT- +! +! NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +! ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +! DIMENSION STATEMENT, +! +! N IS THE ORDER OF THE MATRIX, +! +! D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, +! +! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +! IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, +! +! Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE +! REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS +! OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN +! THE IDENTITY MATRIX. +! +! ON OUTPUT- +! +! D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +! ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT +! UNORDERED FOR INDICES 1,2,...,IERR-1, +! +! E HAS BEEN DESTROYED, +! +! Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC +! TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, +! Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED +! EIGENVALUES, +! +! IERR IS SET TO +! ZERO FOR NORMAL RETURN, +! J IF THE J-TH EIGENVALUE HAS NOT BEEN +! DETERMINED AFTER 30 ITERATIONS. +! +! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +! +! ------------------------------------------------------------------ +! +! ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING +! THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +! +! ********** + MACHEP = 2.0D+00**(-50) +! + IERR = 0 + IF (N .EQ. 1) GO TO 400 +! + DO 100 I = 2, N + 100 E(I-1) = E(I) +! + F = 0.0D+00 + B = 0.0D+00 + E(N) = 0.0D+00 +! + DO 300 L = 1, N + J = 0 + H = MACHEP * (ABS(D(L)) + ABS(E(L))) + IF (B .LT. H) B = H +! ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** + DO 120 M = L, N + IF (ABS(E(M)) .LE. B) GO TO 140 +! ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT +! THROUGH THE BOTTOM OF THE LOOP ********** + 120 CONTINUE +! + 140 IF (M .EQ. L) GO TO 280 + 160 IF (J .EQ. 30) GO TO 380 + J = J + 1 +! ********** FORM SHIFT ********** + L1 = L + 1 + G = D(L) + P = (D(L1) - G) / (2.0D+00 * E(L)) + R = SQRT(P*P+1.0D+00) + D(L) = E(L) / (P + SIGN(R,P)) + H = G - D(L) +! + DO 180 I = L1, N + 180 D(I) = D(I) - H +! + F = F + H +! ********** QL TRANSFORMATION ********** + P = D(M) + C = 1.0D+00 + S = 0.0D+00 + MML = M - L +! ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** + DO 260 II = 1, MML + I = M - II + G = C * E(I) + H = C * P + IF (ABS(P) .LT. ABS(E(I))) GO TO 200 + C = E(I) / P + R = SQRT(C*C+1.0D+00) + E(I+1) = S * P * R + S = C / R + C = 1.0D+00 / R + GO TO 220 + 200 C = P / E(I) + R = SQRT(C*C+1.0D+00) + E(I+1) = S * E(I) * R + S = 1.0D+00 / R + C = C * S + 220 P = C * D(I) - S * G + D(I+1) = H + S * (C * G + S * D(I)) +! ********** FORM VECTOR ********** + CALL DROT(N,Z(1,I+1),1,Z(1,I),1,C,S) +! + 260 CONTINUE +! + E(L) = S * P + D(L) = C * P + IF (ABS(E(L)) .GT. B) GO TO 160 + 280 D(L) = D(L) + F + 300 CONTINUE +! ********** ORDER EIGENVALUES AND EIGENVECTORS ********** + DO 360 II = 2, N + I = II - 1 + K = I + P = D(I) +! + DO 320 J = II, N + IF (D(J) .GE. P) GO TO 320 + K = J + P = D(J) + 320 CONTINUE +! + IF (K .EQ. I) GO TO 360 + D(K) = D(I) + D(I) = P +! + CALL DSWAP(N,Z(1,I),1,Z(1,K),1) +! + 360 CONTINUE +! + GO TO 400 +! ********** SET ERROR -- NO CONVERGENCE TO AN +! EIGENVALUE AFTER 30 ITERATIONS ********** + 380 IERR = L + 400 return +! ********** LAST CARD OF TQL2 ********** + end subroutine TQL2 +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK TRBK3B + subroutine TRBK3B(NM,N,NV,A,M,Z) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: NM,N,NV,M + real(kind=8),DIMENSION(NV) :: A + real(kind=8),DIMENSION(NM,M) :: Z + integer :: i,l,iz,ik,j + real(kind=8) :: h,s +! +! THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, +! NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +! +! THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC +! MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +! SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3B. +! +! ON INPUT- +! +! NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +! ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +! DIMENSION STATEMENT, +! +! N IS THE ORDER OF THE MATRIX, +! +! NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A +! AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, +! +! A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS +! USED IN THE REDUCTION BY TRED3B IN ITS FIRST +! N*(N+1)/2 POSITIONS, +! +! M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, +! +! Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED +! IN ITS FIRST M COLUMNS. +! +! ON OUTPUT- +! +! Z CONTAINS THE TRANSFORMED EIGENVECTORS +! IN ITS FIRST M COLUMNS. +! +! NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. +! +! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +! +! ------------------------------------------------------------------ +! + IF (M .EQ. 0) GO TO 140 + IF (N .EQ. 1) GO TO 140 +! + DO 120 I = 2, N + L = I - 1 + IZ = (I * L) / 2 + IK = IZ + I + H = A(IK) + IF (H .EQ. 0.0D+00) GO TO 120 +! + DO 100 J = 1, M + S = -DDOT(L,A(IZ+1),1,Z(1,J),1) +! +! ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** + S = (S / H) / H +! + CALL DAXPY(L,S,A(IZ+1),1,Z(1,J),1) +! + 100 CONTINUE +! + 120 CONTINUE +! + 140 return +! ********** LAST CARD OF TRBAK3 ********** + end subroutine TRBK3B +!----------------------------------------------------------------------------- +!*MODULE EIGEN *DECK TRED3B + subroutine TRED3B(N,NV,A,D,E,E2) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,NV + real(kind=8),DIMENSION(NV) :: A + real(kind=8),DIMENSION(N) :: D,E2 + real(kind=8) :: E(*)!el E(L) + integer :: ii,i,l,iz,k,jk,j,jm1 + real(kind=8) :: h,f,g,scale,dt,hh +! +! THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, +! NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +! +! THIS ROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS +! A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX +! USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. +! +! ON INPUT- +! +! N IS THE ORDER OF THE MATRIX, +! +! NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A +! AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, +! +! A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC +! INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL +! ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. +! +! ON OUTPUT- +! +! A CONTAINS INFORMATION ABOUT THE ORTHOGONAL +! TRANSFORMATIONS USED IN THE REDUCTION, +! +! D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, +! +! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +! MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, +! +! E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. +! E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. +! +! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +! +! ------------------------------------------------------------------ +! +! ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** + DO 300 II = 1, N + I = N + 1 - II + L = I - 1 + IZ = (I * L) / 2 + H = 0.0D+00 + SCALE = 0.0D+00 + IF (L .LT. 1) GO TO 120 +! ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** + DO 100 K = 1, L + IZ = IZ + 1 + D(K) = A(IZ) + SCALE = SCALE + ABS(D(K)) + 100 CONTINUE +! + IF (SCALE .NE. 0.0D+00) GO TO 140 + 120 E(I) = 0.0D+00 + E2(I) = 0.0D+00 + GO TO 280 +! + 140 DO 160 K = 1, L + D(K) = D(K) / SCALE + H = H + D(K) * D(K) + 160 CONTINUE +! + E2(I) = SCALE * SCALE * H + F = D(L) + G = -SIGN(SQRT(H),F) + E(I) = SCALE * G + H = H - F * G + D(L) = F - G + A(IZ) = SCALE * D(L) + IF (L .EQ. 1) GO TO 280 + F = 0.0D+00 +! + JK = 1 + DO 220 J = 1, L + JM1 = J - 1 + DT = D(J) + G = 0.0D+00 +! ********** FORM ELEMENT OF A*U ********** + IF (JM1 .EQ. 0) GO TO 200 + DO 180 K = 1, JM1 + E(K) = E(K) + DT * A(JK) + G = G + D(K) * A(JK) + JK = JK + 1 + 180 CONTINUE + 200 E(J) = G + A(JK) * DT + JK = JK + 1 +! ********** FORM ELEMENT OF P ********** + 220 CONTINUE + F = 0.0D+00 + DO 240 J = 1, L + E(J) = E(J) / H + F = F + E(J) * D(J) + 240 CONTINUE +! + HH = F / (H + H) + JK = 0 +! ********** FORM REDUCED A ********** + DO 260 J = 1, L + F = D(J) + G = E(J) - HH * F + E(J) = G +! + DO 260 K = 1, J + JK = JK + 1 + A(JK) = A(JK) - F * E(K) - G * D(K) + 260 CONTINUE +! + 280 D(I) = A(IZ+1) + A(IZ+1) = SCALE * SQRT(H) + 300 CONTINUE +! + return +! ********** LAST CARD OF TRED3 ********** + end subroutine TRED3B +!----------------------------------------------------------------------------- +! blas.f +!----------------------------------------------------------------------------- +! 10 NOV 94 - MWS - DNRM2: REMOVE FTNCHECK WARNINGS +! 11 JUN 94 - MWS - INCLUDE A COPY OF DGEMV (LEVEL TWO ROUTINE) +! 11 AUG 87 - MWS - SANITIZE FLOATING POINT CONSTANTS IN DNRM2 +! 26 MAR 87 - MWS - USE GENERIC SIGN IN DROTG +! 28 NOV 86 - STE - SUPPLY ALL LEVEL ONE BLAS +! 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS +! +! BASIC LINEAR ALGEBRA SUBPROGRAMS (BLAS) FROM LINPACK (LEVEL 1) +! +! THIS MODULE SHOULD BE COMPILED ONLY IF SPECIALLY CODED +! VERSIONS OF THESE ROUTINES ARE NOT AVAILABLE ON THE TARGET MACHINE +! +!*MODULE BLAS1 *DECK DASUM + real(kind=8) function DASUM(N,DX,INCX) +! +! TAKES THE SUM OF THE ABSOLUTE VALUES. +! JACK DONGARRA, LINPACK, 3/11/78. +! + real(kind=8) :: DX(1),DTEMP + INTEGER :: I,INCX,M,MP1,N,NINCX +! + DASUM = 0.0D+00 + DTEMP = 0.0D+00 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GO TO 20 +! +! CODE FOR INCREMENT NOT EQUAL TO 1 +! + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DTEMP = DTEMP + ABS(DX(I)) + 10 CONTINUE + DASUM = DTEMP + RETURN +! +! CODE FOR INCREMENT EQUAL TO 1 +! +! +! CLEAN-UP LOOP +! + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + ABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2)) & + + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5)) + 50 CONTINUE + 60 DASUM = DTEMP + return + end function DASUM +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DAXPY + subroutine DAXPY(N,DA,DX,INCX,DY,INCY) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX,INCY + real(kind=8),DIMENSION(1) :: DX,DY + real(kind=8) :: DA +! +! CONSTANT TIMES A VECTOR PLUS A VECTOR. +! DY(I) = DY(I) + DA * DX(I) +! USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer :: ix,iy,i,m,mp1 + IF(N.LE.0)RETURN + IF (DA .EQ. 0.0D+00) RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +! +! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +! NOT EQUAL TO 1 +! + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +! +! CODE FOR BOTH INCREMENTS EQUAL TO 1 +! +! +! CLEAN-UP LOOP +! + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + return + end subroutine DAXPY +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DCOPY + subroutine DCOPY(N,DX,INCX,DY,INCY) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX,INCY + real(kind=8),DIMENSION(*) :: DX,DY +! +! COPIES A VECTOR. +! DY(I) <== DX(I) +! USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer :: ix,iy,m,i,mp1 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +! +! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +! NOT EQUAL TO 1 +! + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +! +! CODE FOR BOTH INCREMENTS EQUAL TO 1 +! +! +! CLEAN-UP LOOP +! + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,7 + DY(I) = DX(I) + DY(I + 1) = DX(I + 1) + DY(I + 2) = DX(I + 2) + DY(I + 3) = DX(I + 3) + DY(I + 4) = DX(I + 4) + DY(I + 5) = DX(I + 5) + DY(I + 6) = DX(I + 6) + 50 CONTINUE + return + end subroutine DCOPY +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DDOT + real(kind=8) function DDOT(N,DX,INCX,DY,INCY) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX,INCY + real(kind=8),DIMENSION(1) :: DX,DY +! +! FORMS THE DOT PRODUCT OF TWO VECTORS. +! DOT = DX(I) * DY(I) +! USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer ::ix,iy,m,mp1,i + real(kind=8) :: DTEMP + DDOT = 0.0D+00 + DTEMP = 0.0D+00 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +! +! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +! NOT EQUAL TO 1 +! + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + DDOT = DTEMP + RETURN +! +! CODE FOR BOTH INCREMENTS EQUAL TO 1 +! +! +! CLEAN-UP LOOP +! + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + & + DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + 60 DDOT = DTEMP + return + end function DDOT +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DNRM2 + real(kind=8) function DNRM2(N,DX,INCX) + + INTEGER :: NEXT,N,INCX + real(kind=8) :: DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE + DATA ZERO, ONE /0.0D+00, 1.0D+00/ + + integer :: i,j,nn +! +! EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +! INCREMENT INCX . +! IF N .LE. 0 RETURN WITH RESULT = 0. +! IF N .GE. 1 THEN INCX MUST BE .GE. 1 +! +! C.L.LAWSON, 1978 JAN 08 +! +! FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +! HOPEFULLY APPLICABLE TO ALL MACHINES. +! CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. +! CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. +! WHERE +! EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +! U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +! V = LARGEST NO. (OVERFLOW LIMIT) +! +! BRIEF OUTLINE OF ALGORITHM.. +! +! PHASE 1 SCANS ZERO COMPONENTS. +! MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +! MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +! MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +! WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. +! +! VALUES FOR CUTLO AND CUTHI.. +! FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +! DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +! CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +! UNIVAC AND DEC AT 2**(-103) +! THUS CUTLO = 2**(-51) = 4.44089E-16 +! CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +! THUS CUTHI = 2**(63.5) = 1.30438E19 +! CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +! THUS CUTLO = 2**(-33.5) = 8.23181D-11 +! CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D+19 +! DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / +! DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / + DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / +! + J=0 + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 +! + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +! BEGIN MAIN LOOP + I = 1 + 20 GO TO NEXT,(30, 50, 70, 110) + 30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO +! +! PHASE 1. SUM IS ZERO +! + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 +! +! PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 +! +! PREPARE FOR PHASE 4. +! + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = ABS(DX(I)) + GO TO 115 +! +! PHASE 2. SUM IS SMALL. +! SCALE TO AVOID DESTRUCTIVE UNDERFLOW. +! + 70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75 +! +! COMMON CODE FOR PHASES 2 AND 4. +! IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. +! + 110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = ABS(DX(I)) + GO TO 200 +! + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 +! +! +! PREPARE FOR PHASE 3. +! + 75 SUM = (SUM * XMAX) * XMAX +! +! +! FOR REAL OR D.P. SET HITEST = CUTHI/N +! FOR COMPLEX SET HITEST = CUTHI/(2*N) +! + 85 HITEST = CUTHI/N +! +! PHASE 3. SUM IS MID-RANGE. NO SCALING. +! + DO 95 J =I,NN,INCX + IF(ABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = SQRT( SUM ) + GO TO 300 +! + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 +! +! END OF MAIN LOOP. +! +! COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. +! + DNRM2 = XMAX * SQRT(SUM) + 300 CONTINUE + return + end function DNRM2 +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DROT + subroutine DROT(N,DX,INCX,DY,INCY,C,S) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX,INCY + real(kind=8),DIMENSION(1) :: DX,DY + real(kind=8) :: C,S +! +! APPLIES A PLANE ROTATION. +! DX(I) = C*DX(I) + S*DY(I) +! DY(I) = -S*DX(I) + C*DY(I) +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer :: ix,iy,i + real(kind=8) :: DTEMP + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +! +! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +! TO 1 +! + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = C*DX(IX) + S*DY(IY) + DY(IY) = C*DY(IY) - S*DX(IX) + DX(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +! +! CODE FOR BOTH INCREMENTS EQUAL TO 1 +! + 20 DO 30 I = 1,N + DTEMP = C*DX(I) + S*DY(I) + DY(I) = C*DY(I) - S*DX(I) + DX(I) = DTEMP + 30 CONTINUE + return + end subroutine DROT +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DROTG + subroutine DROTG(DA,DB,C,S) +! +! CONSTRUCT GIVENS PLANE ROTATION. +! JACK DONGARRA, LINPACK, 3/11/78. +! + real(kind=8) :: DA,DB,C,S,ROE,SCALE,R,Z +! + real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00 +! +!----------------------------------------------------------------------- +! +! + ROE = DB + IF( ABS(DA) .GT. ABS(DB) ) ROE = DA + SCALE = ABS(DA) + ABS(DB) + IF( SCALE .NE. ZERO ) GO TO 10 + C = ONE + S = ZERO + R = ZERO + GO TO 20 +! + 10 R = SCALE*SQRT((DA/SCALE)**2 + (DB/SCALE)**2) + R = SIGN(ONE,ROE)*R + C = DA/R + S = DB/R + 20 Z = ONE + IF( ABS(DA) .GT. ABS(DB) ) Z = S + IF( ABS(DB) .GE. ABS(DA) .AND. C .NE. ZERO ) Z = ONE/C + DA = R + DB = Z + return + end subroutine DROTG +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DSCAL + subroutine DSCAL(N,DA,DX,INCX) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX + real(kind=8),DIMENSION(1) :: DX + real(kind=8) :: DA +! +! SCALES A VECTOR BY A CONSTANT. +! DX(I) = DA * DX(I) +! USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer :: NINCX,m,mp1,i + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GO TO 20 +! +! CODE FOR INCREMENT NOT EQUAL TO 1 +! + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +! +! CODE FOR INCREMENT EQUAL TO 1 +! +! +! CLEAN-UP LOOP +! + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + return + end subroutine DSCAL +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK DSWAP + subroutine DSWAP(N,DX,INCX,DY,INCY) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX,INCY + real(kind=8),DIMENSION(1) :: DX,DY +! +! INTERCHANGES TWO VECTORS. +! DX(I) <==> DY(I) +! USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer :: ix,iy,i,m,mp1 + real(kind=8) :: DTEMP + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +! +! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +! TO 1 +! + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +! +! CODE FOR BOTH INCREMENTS EQUAL TO 1 +! +! +! CLEAN-UP LOOP +! + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I + 1) + DX(I + 1) = DY(I + 1) + DY(I + 1) = DTEMP + DTEMP = DX(I + 2) + DX(I + 2) = DY(I + 2) + DY(I + 2) = DTEMP + 50 CONTINUE + return + end subroutine DSWAP +!----------------------------------------------------------------------------- +!*MODULE BLAS1 *DECK IDAMAX + integer function IDAMAX(N,DX,INCX) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: N,INCX + real(kind=8),DIMENSION(1) :: DX +! +! FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. +! JACK DONGARRA, LINPACK, 3/11/78. +! + integer :: ix,iy,i + real(kind=8) :: RMAX + IDAMAX = 0 + IF( N .LT. 1 ) RETURN + IDAMAX = 1 + IF(N.EQ.1)RETURN + IF(INCX.EQ.1)GO TO 20 +! +! CODE FOR INCREMENT NOT EQUAL TO 1 +! + IX = 1 + RMAX = ABS(DX(1)) + IX = IX + INCX + DO 10 I = 2,N + IF(ABS(DX(IX)).LE.RMAX) GO TO 5 + IDAMAX = I + RMAX = ABS(DX(IX)) + 5 IX = IX + INCX + 10 CONTINUE + RETURN +! +! CODE FOR INCREMENT EQUAL TO 1 +! + 20 RMAX = ABS(DX(1)) + DO 30 I = 2,N + IF(ABS(DX(I)).LE.RMAX) GO TO 30 + IDAMAX = I + RMAX = ABS(DX(I)) + 30 CONTINUE + return + end function IDAMAX +!----------------------------------------------------------------------------- +!*MODULE BLAS *DECK DGEMV + subroutine DGEMV(FORMA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + +! IMPLICIT DOUBLE PRECISION(A-H,O-Z) + integer :: M,N,INCX,INCY,LDA + CHARACTER(len=1) :: FORMA + real(kind=8),DIMENSION(LDA,*) :: A + real(kind=8),DIMENSION(*) :: X,Y + real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00 + real(kind=8) :: ALPHA,BETA + integer :: i,locy +! +! CLONE OF -DGEMV- WRITTEN BY MIKE SCHMIDT +! + LOCY = 1 + IF(FORMA.EQ.'T') GO TO 200 +! +! Y = ALPHA * A * X + BETA * Y +! + IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN + DO 110 I=1,M + Y(LOCY) = DDOT(N,A(I,1),LDA,X,INCX) + LOCY = LOCY+INCY + 110 CONTINUE + ELSE + DO 120 I=1,M + Y(LOCY) = ALPHA*DDOT(N,A(I,1),LDA,X,INCX) + BETA*Y(LOCY) + LOCY = LOCY+INCY + 120 CONTINUE + END IF + RETURN +! +! Y = ALPHA * A-TRANSPOSE * X + BETA * Y +! + 200 CONTINUE + IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN + DO 210 I=1,N + Y(LOCY) = DDOT(M,A(1,I),1,X,INCX) + LOCY = LOCY+INCY + 210 CONTINUE + ELSE + DO 220 I=1,N + Y(LOCY) = ALPHA*DDOT(M,A(1,I),1,X,INCX) + BETA*Y(LOCY) + LOCY = LOCY+INCY + 220 CONTINUE + END IF + return + end subroutine DGEMV +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module MD_calc diff --git a/source/unres/md_calc.f90 b/source/unres/md_calc.f90 deleted file mode 100644 index 50f23d7..0000000 --- a/source/unres/md_calc.f90 +++ /dev/null @@ -1,3365 +0,0 @@ - module MD_calc -!----------------------------------------------------------------------------- - use io_units - use MD_data, only:D_ban,IP - use geometry_data -! use prng ! prng.f90 or prng_32.f90 - implicit none -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! add.f -!----------------------------------------------------------------------------- - subroutine ABRT - STOP 'IN ABRT' - end subroutine ABRT -!----------------------------------------------------------------------------- -!*MODULE MTHLIB *DECK VCLR - subroutine VCLR(A,INCA,N) -! -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) -! - real(kind=8),DIMENSION(*) :: A -! - real(kind=8),PARAMETER :: ZERO=0.0D+00 - integer :: INCA,N - integer :: l,la -! -! ----- ZERO OUT VECTOR -A-, USING INCREMENT -INCA- ----- -! - IF (INCA .NE. 1) GO TO 200 - DO 110 L=1,N - A(L) = ZERO - 110 CONTINUE - RETURN -! - 200 CONTINUE - LA=1-INCA - DO 210 L=1,N - LA=LA+INCA - A(LA) = ZERO - 210 CONTINUE - return - end subroutine VCLR -!----------------------------------------------------------------------------- -! banach.f -!----------------------------------------------------------------------------- - subroutine BANACH(N,NMAX,A,X,osob) -!********************** -! Banachiewicz -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer :: N,NMAX - real(kind=8),DIMENSION(NMAX,NMAX) :: A - real(kind=8),DIMENSION(NMAX) :: X -!el real(kind=8),DIMENSION(6*nres) :: D !(MAXRES6) maxres6=6*maxres -!el COMMON /BANII/ D - logical :: osob - real(kind=8) :: xx,aij,aijd - integer :: i,j,k,jjjj - -!el allocate(D_ban(6*nres)) - - osob=.false. - if (dabs(a(1,1)).lt.1.0d-15) then - osob=.true. - return - endif - D_ban(1)=1./A(1,1) - DO 80 I=2,N - A(I,1)=A(1,I) - DO 81 J=2,I-1 - XX=A(J,I) - DO 82 K=1,J-1 - XX=XX-A(I,K)*A(J,K) - 82 CONTINUE - A(I,J)=XX - 81 CONTINUE - XX=A(I,I) - JJJJ=I-1 - DO 83 J=1,JJJJ - AIJ=A(I,J) - AIJD=AIJ*D_ban(J) - A(I,J)=AIJD - XX=XX-AIJ*AIJD - 83 CONTINUE - if (dabs(xx).lt.1.0d-15) then - osob=.true. - return - endif - D_ban(I)=1./XX - 80 CONTINUE -! - CALL BANAII(N,NMAX,A,X) - return - end subroutine BANACH -!----------------------------------------------------------------------------- - subroutine BANAII(N,NMAX,A,X) -!************************ -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer :: N,NMAX - real(kind=8),DIMENSION(NMAX,NMAX) :: A - real(kind=8),DIMENSION(NMAX) :: X -!el real(kind=8),DIMENSION(6*nres) :: D !(MAXRES6) maxres6=6*maxres -!el COMMON /BANII/ D ---> D_ban - real(kind=8) :: Z - integer :: i,j,jjjj - DO 90 I=1,N - Z=X(I) - JJJJ=I-1 - DO 91 J=JJJJ,1,-1 - Z=Z-A(I,J)*X(J) - 91 CONTINUE - X(I)=Z - 90 CONTINUE - DO 92 I=N,1,-1 - Z=X(I)*D_ban(I) - JJJJ=I+1 - DO 93 J=JJJJ,N - Z=Z-A(J,I)*X(J) - 93 CONTINUE - X(I)=Z - 92 CONTINUE - return - end subroutine BANAII -!----------------------------------------------------------------------------- - subroutine MATINVERT(N,NMAX,A,A1,osob) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer :: N,NMAX - real(kind=8),DIMENSION(NMAX,NMAX) :: A,A1 -!el real(kind=8),DIMENSION(6*nres) :: D !(MAXRES6) maxres6=6*maxres -!el COMMON /BANII/ D - real(kind=8),DIMENSION(NMAX) :: X - logical :: osob - integer :: i,j - DO I=1,N - X(I)=0.0 - ENDDO - X(1)=1.0 - CALL BANACH(N,NMAX,A,X,osob) - if (osob) return - DO I=1,N - A1(I,1)=X(I) - ENDDO - DO I=2,N - DO J=1,N - X(J)=0.0 - ENDDO - X(I)=1.0 - CALL BANAII(N,NMAX,A,X) - DO J=1,N - A1(J,I)=X(J) - ENDDO - ENDDO - return - end subroutine MATINVERT -!----------------------------------------------------------------------------- -! bond_move.f -!----------------------------------------------------------------------------- - subroutine bond_move(nbond,nstart,psi,lprint,error) - - use mcm_data, only:print_mc - use geometry, only:alpha,beta,refsys,matmult -! Move NBOND fragment starting from the CA(nstart) by angle PSI. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer :: nbond,nstart - real(kind=8) :: psi - logical :: fail,error,lprint -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.MCM' - real(kind=8),dimension(3) :: x,e1,e2,e3 - real(kind=8),dimension(3,3) :: e,rot,trans - real(kind=8) :: cospsi,sinpsi,rij - integer :: i,j,nend,i2,i3,i4,k - error=.false. - nend=nstart+nbond - if (print_mc.gt.2) then - write (iout,*) 'nstart=',nstart,' nend=',nend,' nbond=',nbond - write (iout,*) 'psi=',psi - write (iout,'(a)') 'Original coordinates of the fragment' - do i=nstart,nend - write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) - enddo - endif - if (nstart.lt.1 .or. nend .gt.nres .or. nbond.lt.2 .or. & - nbond.ge.nres-1) then - write (iout,'(a)') 'Bad data in BOND_MOVE.' - error=.true. - return - endif -! Generate the reference system. - i2=nend - i3=nstart - i4=nstart+1 - call refsys(i2,i3,i4,e1,e2,e3,error) -! Return, if couldn't define the reference system. - if (error) return -! Compute the transformation matrix. - cospsi=dcos(psi) - sinpsi=dsin(psi) - rot(1,1)=1.0D0 - rot(1,2)=0.0D0 - rot(1,3)=0.0D0 - rot(2,1)=0.0D0 - rot(2,2)=cospsi - rot(2,3)=-sinpsi - rot(3,1)=0.0D0 - rot(3,2)=sinpsi - rot(3,3)=cospsi - do i=1,3 - e(1,i)=e1(i) - e(2,i)=e2(i) - e(3,i)=e3(i) - enddo - - if (print_mc.gt.2) then - write (iout,'(a)') 'Reference system and matrix r:' - do i=1,3 - write(iout,'(i5,2(3f10.5,5x))')i,(e(i,j),j=1,3),(rot(i,j),j=1,3) - enddo - endif - - call matmult(rot,e,trans) - do i=1,3 - do j=1,3 - e(i,1)=e1(i) - e(i,2)=e2(i) - e(i,3)=e3(i) - enddo - enddo - call matmult(e,trans,trans) - - if (lprint) then - write (iout,'(a)') 'The trans matrix:' - do i=1,3 - write (iout,'(i5,3f10.5)') i,(trans(i,j),j=1,3) - enddo - endif - - do i=nstart,nend - do j=1,3 - rij=c(j,nstart) - do k=1,3 - rij=rij+trans(j,k)*(c(k,i)-c(k,nstart)) - enddo - x(j)=rij - enddo - do j=1,3 - c(j,i)=x(j) - enddo - enddo - - if (lprint) then - write (iout,'(a)') 'Rotated coordinates of the fragment' - do i=nstart,nend - write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) - enddo - endif - -! call int_from_cart(.false.,lprint) - if (nstart.gt.1) then - theta(nstart+1)=alpha(nstart-1,nstart,nstart+1) - phi(nstart+2)=beta(nstart-1,nstart,nstart+1,nstart+2) - if (nstart.gt.2) phi(nstart+1)= & - beta(nstart-2,nstart-1,nstart,nstart+1) - endif - if (nend.lt.nres) then - theta(nend+1)=alpha(nend-1,nend,nend+1) - phi(nend+1)=beta(nend-2,nend-1,nend,nend+1) - if (nend.lt.nres-1) phi(nend+2)= & - beta(nend-1,nend,nend+1,nend+2) - endif - if (print_mc.gt.2) then - write (iout,'(/a,i3,a,i3,a/)') & - 'Moved internal coordinates of the ',nstart,'-',nend,& - ' fragment:' - do i=nstart+1,nstart+2 - write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) - enddo - do i=nend+1,nend+2 - write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) - enddo - endif - return - end subroutine bond_move -!----------------------------------------------------------------------------- -! eigen.f -!----------------------------------------------------------------------------- -! 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS -! 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON -! 26 JUN 93 - MWS - ETRED3: ADD RETURN FOR SPECIAL CASE N=1 -! 4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR -! 30 AUG 91 - MWS - JACDIA: LIMIT ITERATIONS, USE EPSLON IN TEST. -! 14 JUL 91 - MWS - JACOBI DIAGONALIZATION ALLOWS FOR LDVEC.NE.N -! 29 JAN 91 - TLW - GLDIAG: CHANGED COMMON DIAGSW TO MACHSW -! 29 OCT 90 - STE - FIX JACDIA UNDEFINED VARIABLE BUG -! 14 SEP 90 - MK - NEW JACOBI DIAGONALIZATION (KDIAG=3) -! 27 MAR 88 - MWS - ALLOW FOR VECTOR ROUTINE IN GLDIAG -! 11 AUG 87 - MWS - SANITIZE CONSTANTS IN EQLRAT -! 15 FEB 87 - STE - FIX EINVIT SUB-MATRIX LOOP LIMIT -! SCRATCH ARRAYS ARE N*8 REAL AND N INTEGER -! 8 DEC 86 - STE - USE PERF INDEX FROM ESTPI1 TO JUDGE EINVIT FAILURE -! 30 NOV 86 - STE - DELETE LIGENB, MAKE EVVRSP DEFAULT -! (GIVEIS FAILS ON CRAY FOR BENCHMC AND BENCHCI) -! 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS -! 11 OCT 85 - STE - LIGENB,TQL2: USE DROT,DSWAP; TINVTB: SCALE VECTOR -! BEFORE NORMALIZING; GENERIC FUNCTIONS -! 24 FEB 84 - STE - INITIALIZE INDEX ARRAY FOR LIGENB IN GLDIAG -! 1 DEC 83 - STE - CHANGE MACHEP FROM 2**-54 TO 2**-50 -! 28 SEP 82 - MWS - CONVERT TO IBM -! -!*MODULE EIGEN *DECK EINVIT - subroutine EINVIT(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) -!* -!* AUTHORS- -!* THIS IS A MODIFICATION OF TINVIT FROM EISPACK EDITION 3 -!* DATED AUGUST 1983. -!* TINVIT IS A TRANSLATION OF THE INVERSE ITERATION TECHNIQUE -!* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. -!* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -!* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -!* -!* PURPOSE - -!* THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL -!* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES. -!* -!* METHOD - -!* INVERSE ITERATION. -!* -!* ON ENTRY - -!* NM - INTEGER -!* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -!* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -!* DIMENSION STATEMENT. -!* N - INTEGER -!* D - W.P. REAL (N) -!* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -!* E - W.P. REAL (N) -!* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -!* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. -!* E2 - W.P. REAL (N) -!* CONTAINS THE SQUARES OF CORRESPONDING ELEMENTS OF E, -!* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. -!* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN -!* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE -!* SUM OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST -!* CONTAIN 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, -!* OR 2.0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. -!* IF TQLRAT, BISECT, TRIDIB, OR IMTQLV -!* HAS BEEN USED TO FIND THE EIGENVALUES, THEIR -!* OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. -!* M - INTEGER -!* THE NUMBER OF SPECIFIED EIGENVECTORS. -!* W - W.P. REAL (M) -!* CONTAINS THE M EIGENVALUES IN ASCENDING -!* OR DESCENDING ORDER. -!* IND - INTEGER (M) -!* CONTAINS IN FIRST M POSITIONS THE SUBMATRIX INDICES -!* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- -!* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX -!* FROM THE TOP, 2 FOR THOSE BELONGING TO THE SECOND -!* SUBMATRIX, ETC. -!* IERR - INTEGER (LOGICAL UNIT NUMBER) -!* LOGICAL UNIT FOR ERROR MESSAGES -!* -!* ON EXIT - -!* ALL INPUT ARRAYS ARE UNALTERED. -!* Z - W.P. REAL (NM,M) -!* CONTAINS THE ASSOCIATED SET OF ORTHONORMAL -!* EIGENVECTORS. ANY VECTOR WHICH WHICH FAILS TO CONVERGE -!* IS LEFT AS IS (BUT NORMALIZED) WHEN ITERATING STOPPED. -!* IERR - INTEGER -!* SET TO -!* ZERO FOR NORMAL RETURN, -!* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH -!* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. -!* (ONLY LAST FAILURE TO CONVERGE IS REPORTED) -!* -!* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. -!* -!* RV1 - W.P. REAL (N) -!* DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -!* RV2 - W.P. REAL (N) -!* SUPER(1)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -!* RV3 - W.P. REAL (N) -!* SUPER(2)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -!* RV4 - W.P. REAL (N) -!* ELEMENTS DEFINING L IN LU DECOMPOSITION -!* RV6 - W.P. REAL (N) -!* APPROXIMATE EIGENVECTOR -!* -!* DIFFERENCES FROM EISPACK 3 - -!* EPS3 IS SCALED BY EPSCAL (ENHANCES CONVERGENCE, BUT -!* LOWERS ACCURACY)! -!* ONE MORE ITERATION (MINIMUM 2) IS PERFORMED AFTER CONVERGENCE -!* (ENHANCES ACCURACY)! -!* REPLACE LOOP WITH PYTHAG WITH SINGLE CALL TO DNRM2! -!* IF NOT CONVERGED, USE PERFORMANCE INDEX TO DECIDE ON ERROR -!* VALUE SETTING, BUT DO NOT STOP! -!* L.U. FOR ERROR MESSAGES PASSED THROUGH IERR -!* USE PARAMETER STATEMENTS AND GENERIC INTRINSIC FUNCTIONS -!* USE LEVEL 1 BLAS -!* USE IF-THEN-ELSE TO CLARIFY LOGIC -!* LOOP OVER SUBSPACES MADE INTO DO LOOP. -!* LOOP OVER INVERSE ITERATIONS MADE INTO DO LOOP -!* ZERO ONLY REQUIRED PORTIONS OF OUTPUT VECTOR -!* -!* NOTE - -!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -!* -! - use comm_par - LOGICAL :: CONVGD !el,GOPARR,DSKWRK,MASWRK -! - INTEGER :: GROUP,I,IERR,ITS,J,JJ,M,N,NM,P,Q,R,S,SUBMAT,TAG - INTEGER :: IND(M) -! - real(kind=8),dimension(N) :: D,E2 - real(kind=8) :: E(*)!el E(L) - real(kind=8) :: W(M),Z(NM,M) - real(kind=8),dimension(N) :: RV1,RV2,RV3,RV4,RV6 - real(kind=8) :: ANORM,EPS2,EPS3,EPS4,NORM,ORDER,RHO,U,UK,V - real(kind=8) :: X0,X1,XU -! real(kind=8) :: ESTPI1 !, DASUM, DDOT, DNRM2 EPSLON, -! -!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM -!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -! - real(kind=8),PARAMETER :: ZERO = 0.0D+00, ONE = 1.0D+00, GRPTOL = 0.001D+00 - real(kind=8),PARAMETER :: EPSCAL = 0.5D+00, HUNDRD = 100.0D+00, TEN = 10.0D+00 -! - 001 FORMAT(' EIGENVECTOR ROUTINE EINVIT DID NOT CONVERGE FOR VECTOR' & - ,I5,'. NORM =',1P,E10.2,' PERFORMANCE INDEX =',E10.2/ & - ' (AN ERROR HALT WILL OCCUR IF THE PI IS GREATER THAN 100)') - integer :: LUEMSG -! -!----------------------------------------------------------------------- -! - LUEMSG = IERR - IERR = 0 - X0 = ZERO - UK = ZERO - NORM = ZERO - EPS2 = ZERO - EPS3 = ZERO - EPS4 = ZERO - GROUP = 0 - TAG = 0 - ORDER = ONE - E2(1) - Q = 0 - DO 930 SUBMAT = 1, N - P = Q + 1 -! -! .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... -! - DO 120 Q = P, N-1 - IF (E2(Q+1) .EQ. ZERO) GO TO 140 - 120 CONTINUE - Q = N -! -! .......... FIND VECTORS BY INVERSE ITERATION .......... -! - 140 CONTINUE - TAG = TAG + 1 - ANORM = ZERO - S = 0 -! - DO 920 R = 1, M - IF (IND(R) .NE. TAG) GO TO 920 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 510 -! -! .......... CHECK FOR ISOLATED ROOT .......... -! - XU = ONE - IF (P .EQ. Q) THEN - RV6(P) = ONE - CONVGD = .TRUE. - GO TO 860 -! - END IF - NORM = ABS(D(P)) - DO 500 I = P+1, Q - NORM = MAX( NORM, ABS(D(I)) + ABS(E(I)) ) - 500 CONTINUE -! -! .......... EPS2 IS THE CRITERION FOR GROUPING, -! EPS3 REPLACES ZERO PIVOTS AND EQUAL -! ROOTS ARE MODIFIED BY EPS3, -! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... -! - EPS2 = GRPTOL * NORM - EPS3 = EPSCAL * EPSLON(NORM) - UK = Q - P + 1 - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - S = P - GROUP = 0 - GO TO 520 -! -! .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... -! - 510 IF (ABS(X1-X0) .GE. EPS2) THEN -! -! ROOTS ARE SEPERATE -! - GROUP = 0 - ELSE -! -! ROOTS ARE CLOSE -! - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. EPS3) X1 = X0 + ORDER * EPS3 - END IF -! -! .......... ELIMINATION WITH INTERCHANGES AND -! INITIALIZATION OF VECTOR .......... -! - 520 CONTINUE -! - U = D(P) - X1 - V = E(P+1) - RV6(P) = UK - DO 550 I = P+1, Q - RV6(I) = UK - IF (ABS(E(I)) .GT. ABS(U)) THEN -! -! EXCHANGE ROWS BEFORE ELIMINATION -! -! *** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -! E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ....... -! - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) -! - ELSE -! -! STRAIGHT ELIMINATION -! - XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = ZERO - U = D(I) - X1 - XU * V - V = E(I+1) - END IF - 550 CONTINUE -! - IF (ABS(U) .LE. EPS3) U = EPS3 - RV1(Q) = U - RV2(Q) = ZERO - RV3(Q) = ZERO -! -! DO INVERSE ITERATIONS -! - CONVGD = .FALSE. - DO 800 ITS = 1, 5 - IF (ITS .EQ. 1) GO TO 600 -! -! .......... FORWARD SUBSTITUTION .......... -! - IF (NORM .EQ. ZERO) THEN - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - ELSE - XU = EPS4 / NORM - CALL DSCAL (Q-P+1, XU, RV6(P), 1) - END IF -! -! ... ELIMINATION OPERATIONS ON NEXT VECTOR -! - DO 590 I = P+1, Q - U = RV6(I) -! -! IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -! WAS PERFORMED EARLIER IN THE -! TRIANGULARIZATION PROCESS .......... -! - IF (RV1(I-1) .EQ. E(I)) THEN - U = RV6(I-1) - RV6(I-1) = RV6(I) - ELSE - U = RV6(I) - END IF - RV6(I) = U - RV4(I) * RV6(I-1) - 590 CONTINUE - 600 CONTINUE -! -! .......... BACK SUBSTITUTION -! - RV6(Q) = RV6(Q) / RV1(Q) - V = U - U = RV6(Q) - NORM = ABS(U) - DO 620 I = Q-1, P, -1 - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - NORM = NORM + ABS(U) - 620 CONTINUE - IF (GROUP .EQ. 0) GO TO 700 -! -! ....... ORTHOGONALIZE WITH RESPECT TO PREVIOUS -! MEMBERS OF GROUP .......... -! - J = R - DO 680 JJ = 1, GROUP - 630 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 630 - CALL DAXPY(Q-P+1, -DDOT(Q-P+1,RV6(P),1,Z(P,J),1),& - Z(P,J),1,RV6(P),1) - 680 CONTINUE - NORM = DASUM(Q-P+1, RV6(P), 1) - 700 CONTINUE -! - IF (CONVGD) GO TO 840 - IF (NORM .GE. ONE) CONVGD = .TRUE. - 800 CONTINUE -! -! .......... NORMALIZE SO THAT SUM OF SQUARES IS -! 1 AND EXPAND TO FULL ORDER .......... -! - 840 CONTINUE -! - XU = ONE / DNRM2(Q-P+1,RV6(P),1) -! - 860 CONTINUE - DO 870 I = 1, P-1 - Z(I,R) = ZERO - 870 CONTINUE - DO 890 I = P,Q - Z(I,R) = RV6(I) * XU - 890 CONTINUE - DO 900 I = Q+1, N - Z(I,R) = ZERO - 900 CONTINUE -! - IF (.NOT.CONVGD) THEN - RHO = ESTPI1(Q-P+1,X1,D(P),E(P),Z(P,R),ANORM) - IF (RHO .GE. TEN .AND. LUEMSG .GT. 0 .AND. MASWRK) & - WRITE(LUEMSG,001) R,NORM,RHO -! -! *** SET ERROR -- NON-CONVERGED EIGENVECTOR .......... -! - IF (RHO .GT. HUNDRD) IERR = -R - END IF -! - X0 = X1 - 920 CONTINUE -! - IF (Q .EQ. N) GO TO 940 - 930 CONTINUE - 940 CONTINUE - return - end subroutine EINVIT -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK ELAUM - subroutine ELAU(HINV,L,D,A,E) -! - integer :: L,JL,JK,J,JM1,K - real(kind=8) :: A(*) - real(kind=8) :: D(L) -!el real(kind=8) :: E(L) - real(kind=8) :: E(*)!el E(L) - real(kind=8) :: F - real(kind=8) :: G - real(kind=8) :: HH - real(kind=8) :: HINV -! - real(kind=8),PARAMETER :: ZERO = 0.0D+00, HALF = 0.5D+00 -! - JL = L - E(1) = A(1) * D(1) - JK = 2 - DO 210 J = 2, JL - F = D(J) - G = ZERO - JM1 = J - 1 -! - DO 200 K = 1, JM1 - G = G + A(JK) * D(K) - E(K) = E(K) + A(JK) * F - JK = JK + 1 - 200 CONTINUE -! - E(J) = G + A(JK) * F - JK = JK + 1 - 210 CONTINUE -! -! .......... FORM P .......... -! - F = ZERO - DO 245 J = 1, L - E(J) = E(J) * HINV - F = F + E(J) * D(J) - 245 CONTINUE -! -! .......... FORM Q .......... -! - HH = F * HALF * HINV - DO 250 J = 1, L - 250 E(J) = E(J) - HH * D(J) -! - return - end subroutine ELAU -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK EPSLON - real(kind=8) function EPSLON(X) -!* -!* AUTHORS - -!* THIS ROUTINE WAS TAKEN FROM EISPACK EDITION 3 DATED 4/6/83 -!* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE NOV 1986 -!* -!* PURPOSE - -!* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. -!* -!* ON ENTRY - -!* X - WORKING PRECISION REAL -!* VALUES TO FIND EPSLON FOR -!* -!* ON EXIT - -!* EPSLON - WORKING PRECISION REAL -!* SMALLEST POSITIVE VALUE SUCH THAT X+EPSLON .NE. ZERO -!* -!* QUALIFICATIONS - -!* THIS ROUTINE SHOULD PERFORM PROPERLY ON ALL SYSTEMS -!* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, -!* 1. THE BASE USED IN REPRESENTING FLOATING POINT -!* NUMBERS IS NOT A POWER OF THREE. -!* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO -!* THE ACCURACY USED IN FLOATING POINT VARIABLES -!* THAT ARE STORED IN MEMORY. -!* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO -!* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING -!* ASSUMPTION 2. -!* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, -!* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, -!* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, -!* C IS NOT EXACTLY EQUAL TO ONE, -!* EPS MEASURES THE SEPARATION OF 1.0 FROM -!* THE NEXT LARGER FLOATING POINT NUMBER. -!* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED -!* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. -!* -!* DIFFERENCES FROM EISPACK 3 - -!* USE IS MADE OF PARAMETER STATEMENTS AND INTRINSIC FUNCTIONS -!* --NO EXECUTEABLE CODE CHANGES-- -!* -!* NOTE - -!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -! - real(kind=8) :: A,B,C,EPS,X -! - real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00, THREE=3.0D+00, FOUR=4.0D+00 -! -!----------------------------------------------------------------------- -! - A = FOUR/THREE - 10 B = A - ONE - C = B + B + B - EPS = ABS(C - ONE) - IF (EPS .EQ. ZERO) GO TO 10 - EPSLON = EPS*ABS(X) - return - end function EPSLON -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK EQLRAT - subroutine EQLRAT(N,DIAG,E,E2IN,D,IND,IERR,E2) -!* -!* AUTHORS - -!* THIS IS A MODIFICATION OF ROUTINE EQLRAT FROM EISPACK EDITION 3 -!* DATED AUGUST 1983. -!* TQLRAT IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, -!* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. -!* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -!* -!* PURPOSE - -!* THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC -!* TRIDIAGONAL MATRIX -!* -!* METHOD - -!* RATIONAL QL -!* -!* ON ENTRY - -!* N - INTEGER -!* THE ORDER OF THE MATRIX. -!* D - W.P. REAL (N) -!* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -!* E2 - W.P. REAL (N) -!* CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF -!* THE INPUT MATRIX IN ITS LAST N-1 POSITIONS. -!* E2(1) IS ARBITRARY. -!* -!* ON EXIT - -!* D - W.P. REAL (N) -!* CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -!* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -!* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -!* THE SMALLEST EIGENVALUES. -!* E2 - W.P. REAL (N) -!* DESTROYED. -!* IERR - INTEGER -!* SET TO -!* ZERO FOR NORMAL RETURN, -!* J IF THE J-TH EIGENVALUE HAS NOT BEEN -!* DETERMINED AFTER 30 ITERATIONS. -!* -!* DIFFERENCES FROM EISPACK 3 - -!* G=G+B INSTEAD OF IF(G.EQ.0) G=B ; B=B/4 -!* F77 BACKWARD LOOPS INSTEAD OF F66 CONSTRUCT -!* GENERIC INTRINSIC FUNCTIONS -!* ARRARY IND ADDED FOR USE BY EINVIT -!* -!* NOTE - -!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -! - INTEGER :: I,J,L,M,N,II,L1,IERR - INTEGER,dimension(N) :: IND -! - real(kind=8),dimension(N) :: D,E,E2,DIAG,E2IN - real(kind=8) :: B,C,F,G,H,P,R,S,T !,EPSLON -! - real(kind=8),PARAMETER :: ZERO = 0.0D+00, SCALE= 1.0D+00/64.0D+00, ONE = 1.0D+00 -! - integer :: K,ITAG -!----------------------------------------------------------------------- - IERR = 0 - D(1)=DIAG(1) - IND(1) = 1 - K = 0 - ITAG = 0 - IF (N .EQ. 1) GO TO 1001 -! - DO 100 I = 2, N - D(I)=DIAG(I) - 100 E2(I-1) = E2IN(I) -! - F = ZERO - T = ZERO - B = EPSLON(ONE) - C = B *B - B = B * SCALE - E2(N) = ZERO -! - DO 290 L = 1, N - H = ABS(D(L)) + ABS(E(L)) - IF (T .GE. H) GO TO 105 - T = H - B = EPSLON(T) - C = B * B - B = B * SCALE - 105 CONTINUE -! .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... - M = L - 1 - 110 M = M + 1 - IF (E2(M) .GT. C) GO TO 110 -! .......... E2(N) IS ALWAYS ZERO, SO THERE IS AN EXIT -! FROM THE LOOP .......... -! - IF (M .LE. K) GO TO 125 - IF (M .NE. N) E2IN(M+1) = ZERO - K = M - ITAG = ITAG + 1 - 125 CONTINUE - IF (M .EQ. L) GO TO 210 -! -! ITERATE -! - DO 205 J = 1, 30 -! .......... FORM SHIFT .......... - L1 = L + 1 - S = SQRT(E2(L)) - G = D(L) - P = (D(L1) - G) / (2.0D+00 * S) - R = SQRT(P*P+1.0D+00) - D(L) = S / (P + SIGN(R,P)) - H = G - D(L) -! - DO 140 I = L1, N - 140 D(I) = D(I) - H -! - F = F + H -! .......... RATIONAL QL TRANSFORMATION .......... - G = D(M) + B - H = G - S = ZERO - DO 200 I = M-1,L,-1 - P = G * H - R = P + E2(I) - E2(I+1) = S * R - S = E2(I) / R - D(I+1) = H + S * (H + D(I)) - G = D(I) - E2(I) / G + B - H = G * P / R - 200 CONTINUE -! - E2(L) = S * G - D(L) = H -! .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST - IF (H .EQ. ZERO) GO TO 210 - IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 - E2(L) = H * E2(L) - IF (E2(L) .EQ. ZERO) GO TO 210 - 205 CONTINUE -! .......... SET ERROR -- NO CONVERGENCE TO AN -! EIGENVALUE AFTER 30 ITERATIONS .......... - IERR = L - GO TO 1001 -! -! CONVERGED -! - 210 P = D(L) + F -! .......... ORDER EIGENVALUES .......... - I = 1 - IF (L .EQ. 1) GO TO 250 - IF (P .LT. D(1)) GO TO 230 - I = L -! .......... LOOP TO FIND ORDERED POSITION - 220 I = I - 1 - IF (P .LT. D(I)) GO TO 220 -! - I = I + 1 - IF (I .EQ. L) GO TO 250 - 230 CONTINUE - DO 240 II = L, I+1, -1 - D(II) = D(II-1) - IND(II) = IND(II-1) - 240 CONTINUE -! - 250 CONTINUE - D(I) = P - IND(I) = ITAG - 290 CONTINUE -! - 1001 return - end subroutine EQLRAT -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK ESTPI1 - real(kind=8) function ESTPI1(N,EVAL,D,E,X,ANORM) -!* -!* AUTHOR - -!* STEPHEN T. ELBERT (AMES LABORATORY-USDOE) DATE: 5 DEC 1986 -!* -!* PURPOSE - -!* EVALUATE SYMMETRIC TRIDIAGONAL MATRIX PERFORMANCE INDEX -!* * * * * * -!* FOR 1 EIGENVECTOR -!* * -!* -!* METHOD - -!* THIS ROUTINE FORMS THE 1-NORM OF THE RESIDUAL MATRIX A*X-X*EVAL -!* WHERE A IS A SYMMETRIC TRIDIAGONAL MATRIX STORED -!* IN THE DIAGONAL (D) AND SUB-DIAGONAL (E) VECTORS, EVAL IS THE -!* EIGENVALUE OF AN EIGENVECTOR OF A, NAMELY X. -!* THIS NORM IS SCALED BY MACHINE ACCURACY FOR THE PROBLEM SIZE. -!* ALL NORMS APPEARING IN THE COMMENTS BELOW ARE 1-NORMS. -!* -!* ON ENTRY - -!* N - INTEGER -!* THE ORDER OF THE MATRIX A. -!* EVAL - W.P. REAL -!* THE EIGENVALUE CORRESPONDING TO VECTOR X. -!* D - W.P. REAL (N) -!* THE DIAGONAL VECTOR OF A. -!* E - W.P. REAL (N) -!* THE SUB-DIAGONAL VECTOR OF A. -!* X - W.P. REAL (N) -!* AN EIGENVECTOR OF A. -!* ANORM - W.P. REAL -!* THE NORM OF A IF IT HAS BEEN PREVIOUSLY COMPUTED. -!* -!* ON EXIT - -!* ANORM - W.P. REAL -!* THE NORM OF A, COMPUTED IF INITIALLY ZERO. -!* ESTPI1 - W.P. REAL -!* !!A*X-X*EVAL!! / (EPSLON(10*N)*!!A!!*!!X!!); -!* WHERE EPSLON(X) IS THE SMALLEST NUMBER SUCH THAT -!* X + EPSLON(X) .NE. X -!* -!* ESTPI1 .LT. 1 == SATISFACTORY PERFORMANCE -!* .GE. 1 AND .LE. 100 == MARGINAL PERFORMANCE -!* .GT. 100 == POOR PERFORMANCE -!* (SEE LECT. NOTES IN COMP. SCI. VOL.6 PP 124-125) -! - integer :: N,I - real(kind=8) :: ANORM,EVAL,RNORM,SIZE,XNORM - real(kind=8),dimension(N) :: D,X - real(kind=8) :: E(*)!el E(L) -! real(kind=8) :: EPSLON -! - real(kind=8),PARAMETER :: ZERO = 0.0D+00, ONE = 1.0D+00 -! -!----------------------------------------------------------------------- -! - ESTPI1 = ZERO - IF( N .LE. 1 ) RETURN - SIZE = 10 * N - IF (ANORM .EQ. ZERO) THEN -! -! COMPUTE NORM OF A -! - ANORM = MAX( ABS(D(1)) + ABS(E(2)), & - ABS(D(N)) + ABS(E(N))) - DO 110 I = 2, N-1 - ANORM = MAX( ANORM, ABS(E(I))+ABS(D(I))+ABS(E(I+1))) - 110 CONTINUE - IF(ANORM .EQ. ZERO) ANORM = ONE - END IF -! -! COMPUTE NORMS OF RESIDUAL AND EIGENVECTOR -! - XNORM = ABS(X(1)) + ABS(X(N)) - RNORM = ABS( (D(1)-EVAL)*X(1) + E(2)*X(2)) & - +ABS( (D(N)-EVAL)*X(N) + E(N)*X(N-1)) - DO 120 I = 2, N-1 - XNORM = XNORM + ABS(X(I)) - RNORM = RNORM + ABS(E(I)*X(I-1) + (D(I)-EVAL)*X(I) & - + E(I+1)*X(I+1)) - 120 CONTINUE -! - ESTPI1 = RNORM / (EPSLON(SIZE)*ANORM*XNORM) - return - end function ESTPI1 -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK ETRBK3 - subroutine ETRBK3(NM,N,NV,A,M,Z) -!* -!* AUTHORS- -!* THIS IS A MODIFICATION OF ROUTINE TRBAK3 FROM EISPACK EDITION 3 -!* DATED AUGUST 1983. -!* EISPACK TRBAK3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, -!* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -!* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -!* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -!* -!* PURPOSE - -!* THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC -!* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -!* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY ETRED3. -!* -!* METHOD - -!* THE CALCULATION IS CARRIED OUT BY FORMING THE MATRIX PRODUCT -!* Q*Z -!* WHERE Q IS A PRODUCT OF THE ORTHOGONAL SYMMETRIC MATRICES -!* Q = PROD(I)[1 - U(I)*.TRANSPOSE.U(I)*H(I)] -!* U IS THE AUGMENTED SUB-DIAGONAL ROWS OF A AND -!* Z IS THE SET OF EIGENVECTORS OF THE TRIDIAGONAL -!* MATRIX F WHICH WAS FORMED FROM THE ORIGINAL SYMMETRIC -!* MATRIX C BY THE SIMILARITY TRANSFORMATION -!* F = Q(TRANSPOSE) C Q -!* NOTE THAT ETRBK3 PRESERVES VECTOR EUCLIDEAN NORMS. -!* -!* -!* COMPLEXITY - -!* M*N**2 -!* -!* ON ENTRY- -!* NM - INTEGER -!* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -!* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -!* DIMENSION STATEMENT. -!* N - INTEGER -!* THE ORDER OF THE MATRIX A. -!* NV - INTEGER -!* MUST BE SET TO THE DIMENSION OF THE ARRAY A AS -!* DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT. -!* A - W.P. REAL (NV) -!* CONTAINS INFORMATION ABOUT THE ORTHOGONAL -!* TRANSFORMATIONS USED IN THE REDUCTION BY ETRED3 IN -!* ITS FIRST NV = N*(N+1)/2 POSITIONS. -!* M - INTEGER -!* THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. -!* Z - W.P REAL (NM,M) -!* CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -!* IN ITS FIRST M COLUMNS. -!* -!* ON EXIT- -!* Z - W.P. REAL (NM,M) -!* CONTAINS THE TRANSFORMED EIGENVECTORS -!* IN ITS FIRST M COLUMNS. -!* -!* DIFFERENCES WITH EISPACK 3 - -!* THE TWO INNER LOOPS ARE REPLACED BY DDOT AND DAXPY. -!* MULTIPLICATION USED INSTEAD OF DIVISION TO FIND S. -!* OUTER LOOP RANGE CHANGED FROM 2,N TO 3,N. -!* ADDRESS POINTERS FOR A SIMPLIFIED. -!* -!* NOTE - -!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -! - INTEGER :: I,II,IM1,IZ,J,M,N,NM,NV -! - real(kind=8) :: A(NV),Z(NM,M) - real(kind=8) :: H,S !,DDOT -! - real(kind=8),PARAMETER :: ZERO = 0.0D+00 -! -!----------------------------------------------------------------------- -! - IF (M .EQ. 0) RETURN - IF (N .LE. 2) RETURN -! - II=3 - DO 140 I = 3, N - IZ=II+1 - II=II+I - H = A(II) - IF (H .EQ. ZERO) GO TO 140 - IM1 = I - 1 - DO 130 J = 1, M - S = -( DDOT(IM1,A(IZ),1,Z(1,J),1) * H) * H - CALL DAXPY(IM1,S,A(IZ),1,Z(1,J),1) - 130 CONTINUE - 140 CONTINUE - return - end subroutine ETRBK3 -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK ETRED3 - subroutine ETRED3(N,NV,A,D,E,E2) -!* -!* AUTHORS - -!* THIS IS A MODIFICATION OF ROUTINE TRED3 FROM EISPACK EDITION 3 -!* DATED AUGUST 1983. -!* EISPACK TRED3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, -!* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -!* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -!* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE JUN 1986 -!* -!* PURPOSE - -!* THIS ROUTINE REDUCES A REAL SYMMETRIC (PACKED) MATRIX, STORED -!* AS A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX -!* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS, PRESERVING THE -!* INFORMATION ABOUT THE TRANSFORMATIONS IN A. -!* -!* METHOD - -!* THE TRIDIAGONAL REDUCTION IS PERFORMED IN THE FOLLOWING WAY. -!* STARTING WITH J=N, THE ELEMENTS IN THE J-TH ROW TO THE -!* LEFT OF THE DIAGONAL ARE FIRST SCALED, TO AVOID POSSIBLE -!* UNDERFLOW IN THE TRANSFORMATION THAT MIGHT RESULT IN SEVERE -!* DEPARTURE FROM ORTHOGONALITY. THE SUM OF SQUARES SIGMA OF -!* THESE SCALED ELEMENTS IS NEXT FORMED. THEN, A VECTOR U AND -!* A SCALAR -!* H = U(TRANSPOSE) * U / 2 -!* DEFINE A REFLECTION OPERATOR -!* P = I - U * U(TRANSPOSE) / H -!* WHICH IS ORTHOGONAL AND SYMMETRIC AND FOR WHICH THE -!* SIMILIARITY TRANSFORMATION PAP ELIMINATES THE ELEMENTS IN -!* THE J-TH ROW OF A TO THE LEFT OF THE SUBDIAGONAL AND THE -!* SYMMETRICAL ELEMENTS IN THE J-TH COLUMN. -!* -!* THE NON-ZERO COMPONENTS OF U ARE THE ELEMENTS OF THE J-TH -!* ROW TO THE LEFT OF THE DIAGONAL WITH THE LAST OF THEM -!* AUGMENTED BY THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN -!* OF THE SUBDIAGONAL ELEMENT. BY STORING THE TRANSFORMED SUB- -!* DIAGONAL ELEMENT IN E(J) AND NOT OVERWRITING THE ROW -!* ELEMENTS ELIMINATED IN THE TRANSFORMATION, FULL INFORMATION -!* ABOUT P IS SAVE FOR LATER USE IN ETRBK3. -!* -!* THE TRANSFORMATION SETS E2(J) EQUAL TO SIGMA AND E(J) -!* EQUAL TO THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN -!* OF THE REPLACED SUBDIAGONAL ELEMENT. -!* -!* THE ABOVE STEPS ARE REPEATED ON FURTHER ROWS OF THE -!* TRANSFORMED A IN REVERSE ORDER UNTIL A IS REDUCED TO TRI- -!* DIAGONAL FORM, THAT IS, REPEATED FOR J = N-1,N-2,...,3. -!* -!* COMPLEXITY - -!* 2/3 N**3 -!* -!* ON ENTRY- -!* N - INTEGER -!* THE ORDER OF THE MATRIX. -!* NV - INTEGER -!* MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -!* AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT -!* A - W.P. REAL (NV) -!* CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC -!* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL -!* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. -!* -!* ON EXIT- -!* A - W.P. REAL (NV) -!* CONTAINS INFORMATION ABOUT THE ORTHOGONAL -!* TRANSFORMATIONS USED IN THE REDUCTION. -!* D - W.P. REAL (N) -!* CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL -!* MATRIX. -!* E - W.P. REAL (N) -!* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -!* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO -!* E2 - W.P. REAL (N) -!* CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF -!* E. MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -!* -!* DIFFERENCES FROM EISPACK 3 - -!* OUTER LOOP CHANGED FROM II=1,N TO I=N,3,-1 -!* PARAMETER STATEMENT AND GENERIC INTRINSIC FUNCTIONS USED -!* SCALE.NE.0 TEST NOW SPOTS TRI-DIAGONAL FORM -!* VALUES LESS THAN EPSLON CLEARED TO ZERO -!* USE BLAS(1) -!* U NOT COPIED TO D, LEFT IN A -!* E2 COMPUTED FROM E -!* INNER LOOPS SPLIT INTO ROUTINES ELAU AND FREDA -!* INVERSE OF H STORED INSTEAD OF H -!* -!* NOTE - -!* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -!* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -! - INTEGER :: I,IIA,IZ0,L,N,NV -! - real(kind=8) :: A(NV),D(N),E2(N) - real(kind=8) :: E(*)!el E(L) - real(kind=8) :: AIIMAX,F,G,H,HROOT,SCALE,SCALEI -! real(kind=8) :: DASUM, DNRM2 -! - real(kind=8),PARAMETER :: ZERO = 0.0D+00, ONE = 1.0D+00 -! -!----------------------------------------------------------------------- -! - IF (N .LE. 2) GO TO 310 - IZ0 = (N*N+N)/2 - AIIMAX = ABS(A(IZ0)) - DO 300 I = N, 3, -1 - L = I - 1 - IIA = IZ0 - IZ0 = IZ0 - I - AIIMAX = MAX(AIIMAX, ABS(A(IIA))) - SCALE = DASUM (L, A(IZ0+1), 1) - IF(SCALE .EQ. ABS(A(IIA-1)) .OR. AIIMAX+SCALE .EQ. AIIMAX) THEN -! -! THIS ROW IS ALREADY IN TRI-DIAGONAL FORM -! - D(I) = A(IIA) - IF (AIIMAX+D(I) .EQ. AIIMAX) D(I) = ZERO - E(I) = A(IIA-1) - IF (AIIMAX+E(I) .EQ. AIIMAX) E(I) = ZERO - E2(I) = E(I)*E(I) - A(IIA) = ZERO - GO TO 300 -! - END IF -! - SCALEI = ONE / SCALE - CALL DSCAL(L,SCALEI,A(IZ0+1),1) - HROOT = DNRM2(L,A(IZ0+1),1) -! - F = A(IZ0+L) - G = -SIGN(HROOT,F) - E(I) = SCALE * G - E2(I) = E(I)*E(I) - H = HROOT*HROOT - F * G - A(IZ0+L) = F - G - D(I) = A(IIA) - A(IIA) = ONE / SQRT(H) -! .......... FORM P THEN Q IN E(1:L) .......... - CALL ELAU(ONE/H,L,A(IZ0+1),A,E) -! .......... FORM REDUCED A .......... - CALL FREDA(L,A(IZ0+1),A,E) -! - 300 CONTINUE - 310 CONTINUE - E(1) = ZERO - E2(1)= ZERO - D(1) = A(1) - IF(N.EQ.1) RETURN -! - E(2) = A(2) - E2(2)= A(2)*A(2) - D(2) = A(3) - return - end subroutine ETRED3 -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK EVVRSP - subroutine EVVRSP(MSGFL,N,NVECT,LENA,NV,A,B,IND,ROOT,VECT,IORDER,IERR) -!* -!* AUTHOR: S. T. ELBERT, AMES LABORATORY-USDOE, JUNE 1985 -!* -!* PURPOSE - -!* FINDS (ALL) EIGENVALUES AND (SOME OR ALL) EIGENVECTORS -!* * * * -!* OF A REAL SYMMETRIC PACKED MATRIX. -!* * * * -!* -!* METHOD - -!* THE METHOD AS PRESENTED IN THIS ROUTINE CONSISTS OF FOUR STEPS: -!* FIRST, THE INPUT MATRIX IS REDUCED TO TRIDIAGONAL FORM BY THE -!* HOUSEHOLDER TECHNIQUE (ORTHOGONAL SIMILARITY TRANSFORMATIONS). -!* SECOND, THE ROOTS ARE LOCATED USING THE RATIONAL QL METHOD. -!* THIRD, THE VECTORS OF THE TRIDIAGONAL FORM ARE EVALUATED BY THE -!* INVERSE ITERATION TECHNIQUE. VECTORS FOR DEGENERATE OR NEAR- -!* DEGENERATE ROOTS ARE FORCED TO BE ORTHOGONAL. -!* FOURTH, THE TRIDIAGONAL VECTORS ARE ROTATED TO VECTORS OF THE -!* ORIGINAL ARRAY. -!* -!* THESE ROUTINES ARE MODIFICATIONS OF THE EISPACK 3 -!* ROUTINES TRED3, TQLRAT, TINVIT AND TRBAK3 -!* -!* FOR FURTHER DETAILS, SEE EISPACK USERS GUIDE, B. T. SMITH -!* ET AL, SPRINGER-VERLAG, LECTURE NOTES IN COMPUTER SCIENCE, -!* VOL. 6, 2-ND EDITION, 1976. ANOTHER GOOD REFERENCE IS -!* THE SYMMETRIC EIGENVALUE PROBLEM BY B. N. PARLETT -!* PUBLISHED BY PRENTICE-HALL, INC., ENGLEWOOD CLIFFS, N.J. (1980) -!* -!* ON ENTRY - -!* MSGFL - INTEGER (LOGICAL UNIT NO.) -!* FILE WHERE ERROR MESSAGES WILL BE PRINTED. -!* IF MSGFL IS 0, ERROR MESSAGES WILL BE PRINTED ON LU 6. -!* IF MSGFL IS NEGATIVE, NO ERROR MESSAGES PRINTED. -!* N - INTEGER -!* ORDER OF MATRIX A. -!* NVECT - INTEGER -!* NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N. -!* LENA - INTEGER -!* DIMENSION OF A IN CALLING ROUTINE. MUST NOT BE LESS -!* THAN (N*N+N)/2. -!* NV - INTEGER -!* ROW DIMENSION OF VECT IN CALLING ROUTINE. N .LE. NV. -!* A - WORKING PRECISION REAL (LENA) -!* INPUT MATRIX, ROWS OF THE LOWER TRIANGLE PACKED INTO -!* LINEAR ARRAY OF DIMENSION N*(N+1)/2. THE PACKED ORDER -!* IS A(1,1), A(2,1), A(2,2), A(3,1), A(3,2), ... -!* B - WORKING PRECISION REAL (N,8) -!* SCRATCH ARRAY, 8*N ELEMENTS -!* IND - INTEGER (N) -!* SCRATCH ARRAY OF LENGTH N. -!* IORDER - INTEGER -!* ROOT ORDERING FLAG. -!* = 0, ROOTS WILL BE PUT IN ASCENDING ORDER. -!* = 2, ROOTS WILL BE PUT IN DESCENDING ORDER. -!* -!* ON EXIT - -!* A - DESTORYED. NOW HOLDS REFLECTION OPERATORS. -!* ROOT - WORKING PRECISION REAL (N) -!* ALL EIGENVALUES IN ASCENDING OR DESCENDING ORDER. -!* IF IORDER = 0, ROOT(1) .LE. ... .LE. ROOT(N) -!* IF IORDER = 2, ROOT(1) .GE. ... .GE. ROOT(N) -!* VECT - WORKING PRECISION REAL (NV,NVECT) -!* EIGENVECTORS FOR ROOT(1), ..., ROOT(NVECT). -!* IERR - INTEGER -!* = 0 IF NO ERROR DETECTED, -!* = K IF ITERATION FOR K-TH EIGENVALUE FAILED, -!* = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. -!* (FAILURES SHOULD BE VERY RARE. CONTACT C. MOLER.) -!* -! - use comm_par -!el LOGICAL :: GOPARR,DSKWRK,MASWRK -! - integer :: MSGFL,N,NVECT,LENA,NV,IORDER,IERR - real(kind=8) :: A(LENA) - real(kind=8) :: B(N,8) - real(kind=8) :: ROOT(N) - real(kind=8) :: T - real(kind=8) :: VECT(NV,*) -! - INTEGER :: IND(N) -! -!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM - real(kind=8) :: DSKW - -!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -! - 900 FORMAT(26H0*** EVVRSP PARAMETERS ***/ & - 14H *** N = ,I8,4H ***/ & - 14H *** NVECT = ,I8,4H ***/ & - 14H *** LENA = ,I8,4H ***/ & - 14H *** NV = ,I8,4H ***/ & - 14H *** IORDER = ,I8,4H ***/ & - 14H *** IERR = ,I8,4H ***) - 901 FORMAT(37H VALUE OF LENA IS LESS THAN (N*N+N)/2) - 902 FORMAT(39H EQLRAT HAS FAILED TO CONVERGE FOR ROOT,I5) - 903 FORMAT(18H NV IS LESS THAN N) - 904 FORMAT(41H EINVIT HAS FAILED TO CONVERGE FOR VECTOR,I5) - 905 FORMAT(51H VALUE OF IORDER MUST BE 0 (SMALLEST ROOT FIRST) OR & - ,23H 2 (LARGEST ROOT FIRST)) - 906 FORMAT(' VALUE OF N IS LESS THAN OR EQUAL ZERO') - - integer :: LMSGFL,I,J,L,JSV,KLIM,K -! -!----------------------------------------------------------------------- -! - LMSGFL=MSGFL - IF (MSGFL .EQ. 0) LMSGFL=6 - IERR = N - 1 - IF (N .LE. 0) GO TO 800 - IERR = N + 1 - IF ( (N*N+N)/2 .GT. LENA) GO TO 810 -! -! REDUCE REAL SYMMETRIC MATRIX A TO TRIDIAGONAL FORM -! - CALL ETRED3(N,LENA,A,B(1,1),B(1,2),B(1,3)) -! -! FIND ALL EIGENVALUES OF TRIDIAGONAL MATRIX -! - CALL EQLRAT(N,B(1,1),B(1,2),B(1,3),ROOT,IND,IERR,B(1,4)) - IF (IERR .NE. 0) GO TO 820 -! -! CHECK THE DESIRED ORDER OF THE EIGENVALUES -! - B(1,3) = IORDER - IF (IORDER .EQ. 0) GO TO 300 - IF (IORDER .NE. 2) GO TO 850 -! -! ORDER ROOTS IN DESCENDING ORDER (LARGEST FIRST)... -! TURN ROOT AND IND ARRAYS END FOR END -! - DO 210 I = 1, N/2 - J = N+1-I - T = ROOT(I) - ROOT(I) = ROOT(J) - ROOT(J) = T - L = IND(I) - IND(I) = IND(J) - IND(J) = L - 210 CONTINUE -! -! FIND I AND J MARKING THE START AND END OF A SEQUENCE -! OF DEGENERATE ROOTS -! - I=0 - 220 CONTINUE - I = I+1 - IF (I .GT. N) GO TO 300 - DO 230 J=I,N - IF (ROOT(J) .NE. ROOT(I)) GO TO 240 - 230 CONTINUE - J = N+1 - 240 CONTINUE - J = J-1 - IF (J .EQ. I) GO TO 220 -! -! TURN AROUND IND BETWEEN I AND J -! - JSV = J - KLIM = (J-I+1)/2 - DO 250 K=1,KLIM - L = IND(J) - IND(J) = IND(I) - IND(I) = L - I = I+1 - J = J-1 - 250 CONTINUE - I = JSV - GO TO 220 -! - 300 CONTINUE -! - IF (NVECT .LE. 0) RETURN - IF (NV .LT. N) GO TO 830 -! -! FIND EIGENVECTORS OF TRI-DIAGONAL MATRIX VIA INVERSE ITERATION -! - IERR = LMSGFL - CALL EINVIT(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,IND,& - VECT,IERR,B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) - IF (IERR .NE. 0) GO TO 840 -! -! FIND EIGENVECTORS OF SYMMETRIC MATRIX VIA BACK TRANSFORMATION -! - 400 CONTINUE - CALL ETRBK3(NV,N,LENA,A,NVECT,VECT) - RETURN -! -! ERROR MESSAGE SECTION -! - 800 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,906) - GO TO 890 -! - 810 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,901) - GO TO 890 -! - 820 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,902) IERR - GO TO 890 -! - 830 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,903) - GO TO 890 -! - 840 CONTINUE - IF ((LMSGFL .GT. 0).AND.MASWRK) WRITE(LMSGFL,904) -IERR - GO TO 400 -! - 850 IERR=-1 - IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,905) - GO TO 890 -! - 890 CONTINUE - IF (MASWRK) WRITE(LMSGFL,900) N,NVECT,LENA,NV,IORDER,IERR - return - end subroutine EVVRSP -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK FREDA - subroutine FREDA(L,D,A,E) -! - integer :: l,jk,j,k - real(kind=8) :: A(*) - real(kind=8) :: D(L) - real(kind=8) :: E(*)!el E(L) - real(kind=8) :: F - real(kind=8) :: G -! - JK = 1 -! -! .......... FORM REDUCED A .......... -! - DO 280 J = 1, L - F = D(J) - G = E(J) -! - DO 260 K = 1, J - A(JK) = A(JK) - F * E(K) - G * D(K) - JK = JK + 1 - 260 CONTINUE -! - 280 CONTINUE - return - end subroutine FREDA -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK GIVEIS - subroutine GIVEIS(N,NVECT,NV,A,B,INDB,ROOT,VECT,IERR) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,NVECT,NV,IERR - real(kind=8),DIMENSION(*) :: A - real(kind=8),DIMENSION(N,8) :: B - integer,DIMENSION(N) :: INDB - real(kind=8),DIMENSION(N) :: ROOT - real(kind=8),DIMENSION(NV,NVECT) :: VECT -! -! EISPACK-BASED SUBSTITUTE FOR QCPE ROUTINE GIVENS. -! FINDS ALL EIGENVALUES AND SOME EIGENVECTORS OF A REAL SYMMETRIC -! MATRIX. AUTHOR.. C. MOLER AND D. SPANGLER, N.R.C.C., 4/1/79. -! -! INPUT.. -! N = ORDER OF MATRIX . -! NVECT = NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N . -! NV = LEADING DIMENSION OF VECT . -! A = INPUT MATRIX, COLUMNS OF THE UPPER TRIANGLE PACKED INTO -! LINEAR ARRAY OF DIMENSION N*(N+1)/2 . -! B = SCRATCH ARRAY, 8*N ELEMENTS (NOTE THIS IS MORE THAN -! PREVIOUS VERSIONS OF GIVENS.) -! IND = INDEX ARRAY OF N ELEMENTS -! -! OUTPUT.. -! A DESTROYED . -! ROOT = ALL EIGENVALUES, ROOT(1) .LE. ... .LE. ROOT(N) . -! (FOR OTHER ORDERINGS, SEE BELOW.) -! VECT = EIGENVECTORS FOR ROOT(1),..., ROOT(NVECT) . -! IERR = 0 IF NO ERROR DETECTED, -! = K IF ITERATION FOR K-TH EIGENVALUE FAILED, -! = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. -! (FAILURES SHOULD BE VERY RARE. CONTACT MOLER.) -! -! CALLS MODIFIED EISPACK ROUTINES TRED3B, IMTQLV, TINVTB, AND -! TRBK3B. THE ROUTINES TRED3B, TINVTB, AND TRBK3B. -! THE ORIGINAL EISPACK ROUTINES TRED3, TINVIT, AND TRBAK3 -! WERE MODIFIED BY THE INTRODUCTION OF TWO ROUTINES FROM THE -! BLAS LIBRARY - DDOT AND DAXPY. -! -! IF TINVIT FAILS TO CONVERGE, TQL2 IS CALLED -! -! SEE EISPACK USERS GUIDE, B. T. SMITH ET AL, SPRINGER-VERLAG -! LECTURE NOTES IN COMPUTER SCIENCE, VOL. 6, 2-ND EDITION, 1976 . -! NOTE THAT IMTQLV AND TINVTB HAVE INTERNAL MACHINE -! DEPENDENT CONSTANTS. -! -!el DATA ONE, ZERO /1.0D+00, 0.0D+00/ - real(kind=8) :: ZERO = 0.0D+00, ONE = 1.0D+00 - - integer :: i,j - - CALL TRED3B(N,(N*N+N)/2,A,B(1,1),B(1,2),B(1,3)) - CALL IMTQLV(N,B(1,1),B(1,2),B(1,3),ROOT,INDB,IERR,B(1,4)) - IF (IERR .NE. 0) RETURN -! -! TO REORDER ROOTS... -! K = N/2 -! B(1,3) = 2.0D+00 -! DO 50 I = 1, K -! J = N+1-I -! T = ROOT(I) -! ROOT(I) = ROOT(J) -! ROOT(J) = T -! 50 CONTINUE -! - IF (NVECT .LE. 0) RETURN - CALL TINVTB(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,INDB,VECT,IERR,& - B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) - IF (IERR .EQ. 0) GO TO 160 -! -! IF INVERSE ITERATION GIVES AN ERROR IN DETERMINING THE -! EIGENVECTORS, TRY THE QL ALGORITHM IF ALL THE EIGENVECTORS -! ARE DESIRED. -! - IF (NVECT .NE. N) RETURN - DO 120 I = 1, NVECT - DO 100 J = 1, N - VECT(I,J) = ZERO - 100 CONTINUE - VECT(I,I) = ONE - 120 CONTINUE - CALL TQL2 (NV,N,B(1,1),B(1,2),VECT,IERR) - DO 140 I = 1, NVECT - ROOT(I) = B(I,1) - 140 CONTINUE - IF (IERR .NE. 0) RETURN - 160 CALL TRBK3B(NV,N,(N*N+N)/2,A,NVECT,VECT) - return - end subroutine GIVEIS -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK GLDIAG - subroutine GLDIAG(LDVECT,NVECT,N,H,WRK,EIG,VECTOR,IERR,IWRK) -! -! IMPLICIT DOUBLE PRECISION (A-H,O-Z) -! - use comm_iofile - use comm_machsw - use comm_par -!el LOGICAL :: GOPARR,DSKWRK,MASWRK -! - integer :: LDVECT,NVECT,N,IERR - real(kind=8),DIMENSION(*) :: H - real(kind=8),DIMENSION(N,8) :: WRK - real(kind=8),DIMENSION(N) :: EIG - integer,DIMENSION(N) :: IWRK - real(kind=8),DIMENSION(LDVECT,NVECT) :: VECTOR -! -!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 -!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM -!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -! - integer :: LENH,KORDER - -! ----- GENERAL ROUTINE TO DIAGONALIZE A SYMMETRIC MATRIX ----- -! IF KDIAG = 0, USE A ROUTINE FROM THE VECTOR LIBRARY, -! IF AVAILABLE (SEE THE SUBROUTINE 'GLDIAG' -! IN VECTOR.SRC), OR EVVRSP OTHERWISE -! = 1, USE EVVRSP -! = 2, USE GIVEIS -! = 3, USE JACOBI -! -! N = DIMENSION (ORDER) OF MATRIX TO BE SOLVED -! LDVECT = LEADING DIMENSION OF VECTOR -! NVECT = NUMBER OF VECTORS DESIRED -! H = MATRIX TO BE DIAGONALIZED -! WRK = N*8 W.P. REAL WORDS OF SCRATCH SPACE -! EIG = EIGENVECTORS (OUTPUT) -! VECTOR = EIGENVECTORS (OUTPUT) -! IERR = ERROR FLAG (OUTPUT) -! IWRK = N INTEGER WORDS OF SCRATCH SPACE -! - IERR = 0 -! -! ----- USE STEVE ELBERT'S ROUTINE ----- -! - IF(KDIAG.LE.1 .OR. KDIAG.GT.3) THEN - LENH = (N*N+N)/2 - KORDER =0 - CALL EVVRSP(IW,N,NVECT,LENH,LDVECT,H,WRK,IWRK,EIG,VECTOR, & - KORDER,IERR) - END IF -! -! ----- USE MODIFIED EISPAK ROUTINE ----- -! - IF(KDIAG.EQ.2) & - CALL GIVEIS(N,NVECT,LDVECT,H,WRK,IWRK,EIG,VECTOR,IERR) -! -! ----- USE JACOBI ROTATION ROUTINE ----- -! - IF(KDIAG.EQ.3) THEN - IF(NVECT.EQ.N) THEN - CALL JACDG(H,VECTOR,EIG,IWRK,WRK,LDVECT,N) - ELSE - IF (MASWRK) WRITE(IW,9000) N,NVECT,LDVECT - CALL ABRT - END IF - END IF - RETURN -! - 9000 FORMAT(1X,'IN -GLDIAG-, N,NVECT,LDVECT=',3I8/ & - 1X,'THE JACOBI CODE CANNOT COPE WITH N.NE.NVECT!'/ & - 1X,'SO THIS RUN DOES NOT PERMIT KDIAG=3.') - end subroutine GLDIAG -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK IMTQLV - subroutine IMTQLV(N,D,E,E2,W,IND,IERR,RV1) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER :: N,TAG,IERR - real(kind=8) :: MACHEP - real(kind=8),DIMENSION(N) :: D,E2,W,RV1 - real(kind=8) :: E(*)!el E(L) - integer,DIMENSION(N) :: IND - integer :: k,i,l,j,m,mml,ii - real(kind=8) :: c,p,s,f,b,g,r -! -! THIS ROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF -! ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND -! WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. -! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). -! -! THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL -! MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM -! THEIR CORRESPONDING SUBMATRIX INDICES. -! -! ON INPUT- -! -! N IS THE ORDER OF THE MATRIX, -! -! D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -! -! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -! IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -! -! E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -! E2(1) IS ARBITRARY. -! -! ON OUTPUT- -! -! D AND E ARE UNALTERED, -! -! ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED -! AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE -! MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. -! E2(1) IS ALSO SET TO ZERO, -! -! W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -! ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -! ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -! THE SMALLEST EIGENVALUES, -! -! IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE -! CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES -! BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, -! 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC., -! -! IERR IS SET TO -! ZERO FOR NORMAL RETURN, -! J IF THE J-TH EIGENVALUE HAS NOT BEEN -! DETERMINED AFTER 30 ITERATIONS, -! -! RV1 IS A TEMPORARY STORAGE ARRAY. -! -! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -! -! ------------------------------------------------------------------ -! -! ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -! THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -! -! ********** - MACHEP = 2.0D+00**(-50) -! - IERR = 0 - K = 0 - TAG = 0 -! - DO 100 I = 1, N - W(I) = D(I) - IF (I .NE. 1) RV1(I-1) = E(I) - 100 CONTINUE -! - E2(1) = 0.0D+00 - RV1(N) = 0.0D+00 -! - DO 360 L = 1, N - J = 0 -! ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** - 120 DO 140 M = L, N - IF (M .EQ. N) GO TO 160 - IF (ABS(RV1(M)) .LE. MACHEP * (ABS(W(M)) + ABS(W(M+1)))) GO TO & - 160 -! ********** GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ********** - IF (E2(M+1) .EQ. 0.0D+00) GO TO 180 - 140 CONTINUE -! - 160 IF (M .LE. K) GO TO 200 - IF (M .NE. N) E2(M+1) = 0.0D+00 - 180 K = M - TAG = TAG + 1 - 200 P = W(L) - IF (M .EQ. L) GO TO 280 - IF (J .EQ. 30) GO TO 380 - J = J + 1 -! ********** FORM SHIFT ********** - G = (W(L+1) - P) / (2.0D+00 * RV1(L)) - R = SQRT(G*G+1.0D+00) - G = W(M) - P + RV1(L) / (G + SIGN(R,G)) - S = 1.0D+00 - C = 1.0D+00 - P = 0.0D+00 - MML = M - L -! ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** - DO 260 II = 1, MML - I = M - II - F = S * RV1(I) - B = C * RV1(I) - IF (ABS(F) .LT. ABS(G)) GO TO 220 - C = G / F - R = SQRT(C*C+1.0D+00) - RV1(I+1) = F * R - S = 1.0D+00 / R - C = C * S - GO TO 240 - 220 S = F / G - R = SQRT(S*S+1.0D+00) - RV1(I+1) = G * R - C = 1.0D+00 / R - S = S * C - 240 G = W(I+1) - P - R = (W(I) - G) * S + 2.0D+00 * C * B - P = S * R - W(I+1) = G + P - G = C * R - B - 260 CONTINUE -! - W(L) = W(L) - P - RV1(L) = G - RV1(M) = 0.0D+00 - GO TO 120 -! ********** ORDER EIGENVALUES ********** - 280 IF (L .EQ. 1) GO TO 320 -! ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** - DO 300 II = 2, L - I = L + 2 - II - IF (P .GE. W(I-1)) GO TO 340 - W(I) = W(I-1) - IND(I) = IND(I-1) - 300 CONTINUE -! - 320 I = 1 - 340 W(I) = P - IND(I) = TAG - 360 CONTINUE -! - GO TO 400 -! ********** SET ERROR -- NO CONVERGENCE TO AN -! EIGENVALUE AFTER 30 ITERATIONS ********** - 380 IERR = L - 400 return -! ********** LAST CARD OF IMTQLV ********** - end subroutine IMTQLV -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK JACDG - subroutine JACDG(A,VEC,EIG,JBIG,BIG,LDVEC,N) -! -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) -! - integer :: LDVEC,N - real(kind=8),DIMENSION(*) :: A - real(kind=8),DIMENSION(LDVEC,N) :: VEC - real(kind=8),DIMENSION(N) :: EIG,BIG - integer,DIMENSION(N) :: JBIG -! - real(kind=8),PARAMETER :: ONE=1.0D+00 - integer :: i,NB1,NB2,NMIN,NMAX -! -! ----- JACOBI DIAGONALIZATION OF SYMMETRIC MATRIX ----- -! SYMMETRIC MATRIX -A- OF DIMENSION -N- IS DESTROYED ON EXIT. -! ALL EIGENVECTORS ARE FOUND, SO -VEC- MUST BE SQUARE, -! UNLESS SOMEONE TAKES THE TROUBLE TO LOOK AT -NMAX- BELOW. -! -BIG- AND -JBIG- ARE SCRATCH WORK ARRAYS. -! - CALL VCLR(VEC,1,LDVEC*N) - DO 20 I = 1,N - VEC(I,I) = ONE - 20 CONTINUE -! - NB1 = N - NB2 = (NB1*NB1+NB1)/2 - NMIN = 1 - NMAX = NB1 -! - CALL JACDIA(A,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) -! - DO 30 I=1,N - EIG(I) = A((I*I+I)/2) - 30 CONTINUE -! - CALL JACORD(VEC,EIG,NB1,LDVEC) - return - end subroutine JACDG -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK JACDIA - subroutine JACDIA(F,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - use comm_par - integer :: NB1,NB2,LDVEC,NMIN,NMAX -!el LOGICAL :: GOPARR,DSKWRK,MASWRK - real(kind=8),DIMENSION(NB2) :: F - real(kind=8),DIMENSION(LDVEC,NB1) :: VEC - real(kind=8),DIMENSION(NB1) :: BIG - integer,DIMENSION(NB1) :: JBIG -! -!el integer :: ME,MASTER,NPROC,IBTYP,IPTIM -!el COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -! - real(kind=8),PARAMETER :: ROOT2=0.707106781186548D+00 - real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00, D1050=1.05D+00,& - D1500=1.5D+00, D3875=3.875D+00,& - D0500=0.5D+00, D1375=1.375D+00, D0250=0.25D+00 - real(kind=8),PARAMETER :: C2=1.0D-12, C3=4.0D-16,& - C4=2.0D-16, C5=8.0D-09, C6=3.0D-06 - integer :: i,ii,j,k,jj,IEAA,IEAB,MAXIT,ITER,I1,IA,IB,IAA,IBB,IEAR,& - IEBR,IR,IT,KQ,IR1 - real(kind=8) :: T,TT,EPS,SD,TEST,DIF,CX,SX,T2X2,T2X25,T1,T2 -! -! F IS THE MATRIX TO BE DIAGONALIZED, F IS STORED TRIANGULAR -! VEC IS THE ARRAY OF EIGENVECTORS, DIMENSION NB1*NB1 -! BIG AND JBIG ARE TEMPORARY SCRATCH AREAS OF DIMENSION NB1 -! THE ROTATIONS AMONG THE FIRST NMIN BASIS FUNCTIONS ARE NOT -! ACCOUNTED FOR. -! THE ROTATIONS AMONG THE LAST NB1-NMAX BASIS FUNCTIONS ARE NOT -! ACCOUNTED FOR. -! - IEAA=0 - IEAB=0 - TT=ZERO - EPS = 64.0D+00*EPSLON(ONE) -! -! LOOP OVER COLUMNS (K) OF TRIANGULAR MATRIX TO DETERMINE -! LARGEST OFF-DIAGONAL ELEMENTS IN ROW(I). -! - DO 20 I=1,NB1 - BIG(I)=ZERO - JBIG(I)=0 - IF(I.LT.NMIN .OR. I.EQ.1) GO TO 20 - II = (I*I-I)/2 - J=MIN(I-1,NMAX) - DO 10 K=1,J - IF(ABS(BIG(I)).GE.ABS(F(II+K))) GO TO 10 - BIG(I)=F(II+K) - JBIG(I)=K - 10 CONTINUE - 20 CONTINUE -! -! ----- 2X2 JACOBI ITERATIONS BEGIN HERE ----- -! - MAXIT=MAX(NB2*20,500) - ITER=0 - 30 CONTINUE - ITER=ITER+1 -! -! FIND SMALLEST DIAGONAL ELEMENT -! - SD=D1050 - JJ=0 - DO 40 J=1,NB1 - JJ=JJ+J - SD= MIN(SD,ABS(F(JJ))) - 40 CONTINUE - TEST = MAX(EPS, C2*MAX(SD,C6)) -! -! FIND LARGEST OFF-DIAGONAL ELEMENT -! - T=ZERO - I1=MAX(2,NMIN) - IB = I1 - DO 50 I=I1,NB1 - IF(T.GE.ABS(BIG(I))) GO TO 50 - T= ABS(BIG(I)) - IB=I - 50 CONTINUE -! -! TEST FOR CONVERGENCE, THEN DETERMINE ROTATION. -! - IF(T.LT.TEST) RETURN -! ****** -! - IF(ITER.GT.MAXIT) THEN - IF (MASWRK) THEN - WRITE(6,*) 'JACOBI DIAGONALIZATION FAILS, DIMENSION=',NB1 - WRITE(6,9020) ITER,T,TEST,SD - ENDIF - CALL ABRT - STOP - END IF -! - IA=JBIG(IB) - IAA=IA*(IA-1)/2 - IBB=IB*(IB-1)/2 - DIF=F(IAA+IA)-F(IBB+IB) - IF(ABS(DIF).GT.C3*T) GO TO 70 - SX=ROOT2 - CX=ROOT2 - GO TO 110 - 70 T2X2=BIG(IB)/DIF - T2X25=T2X2*T2X2 - IF(T2X25 .GT. C4) GO TO 80 - CX=ONE - SX=T2X2 - GO TO 110 - 80 IF(T2X25 .GT. C5) GO TO 90 - SX=T2X2*(ONE-D1500*T2X25) - CX=ONE-D0500*T2X25 - GO TO 110 - 90 IF(T2X25 .GT. C6) GO TO 100 - CX=ONE+T2X25*(T2X25*D1375 - D0500) - SX= T2X2*(ONE + T2X25*(T2X25*D3875 - D1500)) - GO TO 110 - 100 T=D0250 / SQRT(D0250 + T2X25) - CX= SQRT(D0500 + T) - SX= SIGN( SQRT(D0500 - T),T2X2) - 110 IEAR=IAA+1 - IEBR=IBB+1 -! - DO 230 IR=1,NB1 - T=F(IEAR)*SX - F(IEAR)=F(IEAR)*CX+F(IEBR)*SX - F(IEBR)=T-F(IEBR)*CX - IF(IR-IA) 220,120,130 - 120 TT=F(IEBR) - IEAA=IEAR - IEAB=IEBR - F(IEBR)=BIG(IB) - IEAR=IEAR+IR-1 - IF(JBIG(IR)) 200,220,200 - 130 T=F(IEAR) - IT=IA - IEAR=IEAR+IR-1 - IF(IR-IB) 180,150,160 - 150 F(IEAA)=F(IEAA)*CX+F(IEAB)*SX - F(IEAB)=TT*CX+F(IEBR)*SX - F(IEBR)=TT*SX-F(IEBR)*CX - IEBR=IEBR+IR-1 - GO TO 200 - 160 IF( ABS(T) .GE. ABS(F(IEBR))) GO TO 170 - IF(IB.GT.NMAX) GO TO 170 - T=F(IEBR) - IT=IB - 170 IEBR=IEBR+IR-1 - 180 IF( ABS(T) .LT. ABS(BIG(IR))) GO TO 190 - BIG(IR) = T - JBIG(IR) = IT - GO TO 220 - 190 IF(IA .NE. JBIG(IR) .AND. IB .NE. JBIG(IR)) GO TO 220 - 200 KQ=IEAR-IR-IA+1 - BIG(IR)=ZERO - IR1=MIN(IR-1,NMAX) - DO 210 I=1,IR1 - K=KQ+I - IF(ABS(BIG(IR)) .GE. ABS(F(K))) GO TO 210 - BIG(IR) = F(K) - JBIG(IR)=I - 210 CONTINUE - 220 IEAR=IEAR+1 - 230 IEBR=IEBR+1 -! - DO 240 I=1,NB1 - T1=VEC(I,IA)*CX + VEC(I,IB)*SX - T2=VEC(I,IA)*SX - VEC(I,IB)*CX - VEC(I,IA)=T1 - VEC(I,IB)=T2 - 240 CONTINUE - GO TO 30 -! - 9020 FORMAT(1X,'ITER=',I6,' T,TEST,SD=',1P,3E20.10) - end subroutine JACDIA -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK JACORD - subroutine JACORD(VEC,EIG,N,LDVEC) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,LDVEC - real(kind=8),DIMENSION(LDVEC,N) :: VEC - real(kind=8),DIMENSION(N) :: EIG - integer :: i,jj,j - real(kind=8) :: T -! -! ---- SORT EIGENDATA INTO ASCENDING ORDER ----- -! - DO 290 I = 1, N - JJ = I - DO 270 J = I, N - IF (EIG(J) .LT. EIG(JJ)) JJ = J - 270 CONTINUE - IF (JJ .EQ. I) GO TO 290 - T = EIG(JJ) - EIG(JJ) = EIG(I) - EIG(I) = T - DO 280 J = 1, N - T = VEC(J,JJ) - VEC(J,JJ) = VEC(J,I) - VEC(J,I) = T - 280 CONTINUE - 290 CONTINUE - return - end subroutine JACORD -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK TINVTB - subroutine TINVTB(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: NM,N,M,IERR - real(kind=8),DIMENSION(N) :: D,E,E2 - real(kind=8),DIMENSION(M) :: W - real(kind=8),DIMENSION(NM,M) :: Z - real(kind=8),DIMENSION(N) :: RV1,RV2,RV3,RV4,RV6 - integer,DIMENSION(M) :: IND - real(kind=8) :: MACHEP,NORM - INTEGER :: P,Q,R,S,TAG,GROUP - integer :: ii,j,jj,i,iqmp,its - real(kind=8) :: ORDER,XU,UK,X0,U,EPS2,EPS3,EPS4,x1,v - -! ------------------------------------------------------------------ -! -! THIS ROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- -! NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. -! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -! -! THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL -! SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, -! USING INVERSE ITERATION. -! -! ON INPUT- -! -! NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -! ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -! DIMENSION STATEMENT, -! -! N IS THE ORDER OF THE MATRIX, -! -! D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -! -! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -! IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -! -! E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, -! WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. -! E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN -! THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM -! OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN -! 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0 -! IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, -! TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, -! THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE, -! -! M IS THE NUMBER OF SPECIFIED EIGENVALUES, -! -! W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER, -! -! IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES -! ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- -! 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM -! THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. -! -! ON OUTPUT- -! -! ALL INPUT ARRAYS ARE UNALTERED, -! -! Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. -! ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO, -! -! IERR IS SET TO -! ZERO FOR NORMAL RETURN, -! -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH -! EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS, -! -! RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. -! -! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -! -! ------------------------------------------------------------------ -! -! ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -! THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -! -! ********** - MACHEP = 2.0D+00**(-50) -! - IERR = 0 - IF (M .EQ. 0) GO TO 680 - TAG = 0 - ORDER = 1.0D+00 - E2(1) - XU = 0.0D+00 - UK = 0.0D+00 - X0 = 0.0D+00 - U = 0.0D+00 - EPS2 = 0.0D+00 - EPS3 = 0.0D+00 - EPS4 = 0.0D+00 - GROUP = 0 - Q = 0 -! ********** ESTABLISH AND PROCESS NEXT SUBMATRIX ********** - 100 P = Q + 1 - IP = P + 1 -! - DO 120 Q = P, N - IF (Q .EQ. N) GO TO 140 - IF (E2(Q+1) .EQ. 0.0D+00) GO TO 140 - 120 CONTINUE -! ********** FIND VECTORS BY INVERSE ITERATION ********** - 140 TAG = TAG + 1 - IQMP = Q - P + 1 - S = 0 -! - DO 660 R = 1, M - IF (IND(R) .NE. TAG) GO TO 660 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 220 -! ********** CHECK FOR ISOLATED ROOT ********** - XU = 1.0D+00 - IF (P .NE. Q) GO TO 160 - RV6(P) = 1.0D+00 - GO TO 600 - 160 NORM = ABS(D(P)) -! - DO 180 I = IP, Q - 180 NORM = NORM + ABS(D(I)) + ABS(E(I)) -! ********** EPS2 IS THE CRITERION FOR GROUPING, -! EPS3 REPLACES ZERO PIVOTS AND EQUAL -! ROOTS ARE MODIFIED BY EPS3, -! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ********** - EPS2 = 1.0D-03 * NORM - EPS3 = MACHEP * NORM - UK = IQMP - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - S = P - 200 GROUP = 0 - GO TO 240 -! ********** LOOK FOR CLOSE OR COINCIDENT ROOTS ********** - 220 IF (ABS(X1-X0) .GE. EPS2) GO TO 200 - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. 0.0D+00) X1 = X0 + ORDER * EPS3 -! ********** ELIMINATION WITH INTERCHANGES AND -! INITIALIZATION OF VECTOR ********** - 240 V = 0.0D+00 -! - DO 300 I = P, Q - RV6(I) = UK - IF (I .EQ. P) GO TO 280 - IF (ABS(E(I)) .LT. ABS(U)) GO TO 260 -! ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -! E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ********** - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = 0.0D+00 - IF (I .NE. Q) RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) - GO TO 300 - 260 XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = 0.0D+00 - 280 U = D(I) - X1 - XU * V - IF (I .NE. Q) V = E(I+1) - 300 CONTINUE -! - IF (U .EQ. 0.0D+00) U = EPS3 - RV1(Q) = U - RV2(Q) = 0.0D+00 - RV3(Q) = 0.0D+00 -! ********** BACK SUBSTITUTION -! FOR I=Q STEP -1 UNTIL P DO -- ********** - 320 DO 340 II = P, Q - I = P + Q - II - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - 340 CONTINUE -! ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS -! MEMBERS OF GROUP ********** - IF (GROUP .EQ. 0) GO TO 400 - J = R -! - DO 380 JJ = 1, GROUP - 360 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 360 - XU = DDOT(IQMP,RV6(P),1,Z(P,J),1) -! - CALL DAXPY(IQMP,-XU,Z(P,J),1,RV6(P),1) -! - 380 CONTINUE -! - 400 NORM = 0.0D+00 -! - DO 420 I = P, Q - 420 NORM = NORM + ABS(RV6(I)) -! - IF (NORM .GE. 1.0D+00) GO TO 560 -! ********** FORWARD SUBSTITUTION ********** - IF (ITS .EQ. 5) GO TO 540 - IF (NORM .NE. 0.0D+00) GO TO 440 - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - GO TO 480 - 440 XU = EPS4 / NORM -! - DO 460 I = P, Q - 460 RV6(I) = RV6(I) * XU -! ********** ELIMINATION OPERATIONS ON NEXT VECTOR -! ITERATE ********** - 480 DO 520 I = IP, Q - U = RV6(I) -! ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -! WAS PERFORMED EARLIER IN THE -! TRIANGULARIZATION PROCESS ********** - IF (RV1(I-1) .NE. E(I)) GO TO 500 - U = RV6(I-1) - RV6(I-1) = RV6(I) - 500 RV6(I) = U - RV4(I) * RV6(I-1) - 520 CONTINUE -! - ITS = ITS + 1 - GO TO 320 -! ********** SET ERROR -- NON-CONVERGED EIGENVECTOR ********** - 540 IERR = -R - XU = 0.0D+00 - GO TO 600 -! ********** NORMALIZE SO THAT SUM OF SQUARES IS -! 1 AND EXPAND TO FULL ORDER ********** - 560 U = 0.0D+00 -! - DO 580 I = P, Q - RV6(I) = RV6(I) / NORM - 580 U = U + RV6(I)**2 -! - XU = 1.0D+00 / SQRT(U) -! - 600 DO 620 I = 1, N - 620 Z(I,R) = 0.0D+00 -! - DO 640 I = P, Q - 640 Z(I,R) = RV6(I) * XU -! - X0 = X1 - 660 CONTINUE -! - IF (Q .LT. N) GO TO 100 - 680 return -! ********** LAST CARD OF TINVIT ********** - end subroutine TINVTB -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK TQL2 - subroutine TQL2(NM,N,D,E,Z,IERR) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: NM,N,IERR - real(kind=8) :: MACHEP - real(kind=8),DIMENSION(N) :: D!,E - real(kind=8) :: E(*)!el E(L) - real(kind=8),DIMENSION(NM,N) :: Z - integer :: ii,i,j,mml,m,l1,k,l - real(kind=8) :: c,f,b,h,g,p,r,s -! -! THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, -! NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND -! WILKINSON. -! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). -! -! THIS ROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS -! OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. -! THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO -! BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS -! FULL MATRIX TO TRIDIAGONAL FORM. -! -! ON INPUT- -! -! NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -! ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -! DIMENSION STATEMENT, -! -! N IS THE ORDER OF THE MATRIX, -! -! D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -! -! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -! IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -! -! Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE -! REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS -! OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN -! THE IDENTITY MATRIX. -! -! ON OUTPUT- -! -! D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -! ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT -! UNORDERED FOR INDICES 1,2,...,IERR-1, -! -! E HAS BEEN DESTROYED, -! -! Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC -! TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, -! Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED -! EIGENVALUES, -! -! IERR IS SET TO -! ZERO FOR NORMAL RETURN, -! J IF THE J-TH EIGENVALUE HAS NOT BEEN -! DETERMINED AFTER 30 ITERATIONS. -! -! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -! -! ------------------------------------------------------------------ -! -! ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -! THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -! -! ********** - MACHEP = 2.0D+00**(-50) -! - IERR = 0 - IF (N .EQ. 1) GO TO 400 -! - DO 100 I = 2, N - 100 E(I-1) = E(I) -! - F = 0.0D+00 - B = 0.0D+00 - E(N) = 0.0D+00 -! - DO 300 L = 1, N - J = 0 - H = MACHEP * (ABS(D(L)) + ABS(E(L))) - IF (B .LT. H) B = H -! ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** - DO 120 M = L, N - IF (ABS(E(M)) .LE. B) GO TO 140 -! ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -! THROUGH THE BOTTOM OF THE LOOP ********** - 120 CONTINUE -! - 140 IF (M .EQ. L) GO TO 280 - 160 IF (J .EQ. 30) GO TO 380 - J = J + 1 -! ********** FORM SHIFT ********** - L1 = L + 1 - G = D(L) - P = (D(L1) - G) / (2.0D+00 * E(L)) - R = SQRT(P*P+1.0D+00) - D(L) = E(L) / (P + SIGN(R,P)) - H = G - D(L) -! - DO 180 I = L1, N - 180 D(I) = D(I) - H -! - F = F + H -! ********** QL TRANSFORMATION ********** - P = D(M) - C = 1.0D+00 - S = 0.0D+00 - MML = M - L -! ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** - DO 260 II = 1, MML - I = M - II - G = C * E(I) - H = C * P - IF (ABS(P) .LT. ABS(E(I))) GO TO 200 - C = E(I) / P - R = SQRT(C*C+1.0D+00) - E(I+1) = S * P * R - S = C / R - C = 1.0D+00 / R - GO TO 220 - 200 C = P / E(I) - R = SQRT(C*C+1.0D+00) - E(I+1) = S * E(I) * R - S = 1.0D+00 / R - C = C * S - 220 P = C * D(I) - S * G - D(I+1) = H + S * (C * G + S * D(I)) -! ********** FORM VECTOR ********** - CALL DROT(N,Z(1,I+1),1,Z(1,I),1,C,S) -! - 260 CONTINUE -! - E(L) = S * P - D(L) = C * P - IF (ABS(E(L)) .GT. B) GO TO 160 - 280 D(L) = D(L) + F - 300 CONTINUE -! ********** ORDER EIGENVALUES AND EIGENVECTORS ********** - DO 360 II = 2, N - I = II - 1 - K = I - P = D(I) -! - DO 320 J = II, N - IF (D(J) .GE. P) GO TO 320 - K = J - P = D(J) - 320 CONTINUE -! - IF (K .EQ. I) GO TO 360 - D(K) = D(I) - D(I) = P -! - CALL DSWAP(N,Z(1,I),1,Z(1,K),1) -! - 360 CONTINUE -! - GO TO 400 -! ********** SET ERROR -- NO CONVERGENCE TO AN -! EIGENVALUE AFTER 30 ITERATIONS ********** - 380 IERR = L - 400 return -! ********** LAST CARD OF TQL2 ********** - end subroutine TQL2 -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK TRBK3B - subroutine TRBK3B(NM,N,NV,A,M,Z) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: NM,N,NV,M - real(kind=8),DIMENSION(NV) :: A - real(kind=8),DIMENSION(NM,M) :: Z - integer :: i,l,iz,ik,j - real(kind=8) :: h,s -! -! THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, -! NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -! -! THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC -! MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -! SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3B. -! -! ON INPUT- -! -! NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -! ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -! DIMENSION STATEMENT, -! -! N IS THE ORDER OF THE MATRIX, -! -! NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -! AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, -! -! A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS -! USED IN THE REDUCTION BY TRED3B IN ITS FIRST -! N*(N+1)/2 POSITIONS, -! -! M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, -! -! Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -! IN ITS FIRST M COLUMNS. -! -! ON OUTPUT- -! -! Z CONTAINS THE TRANSFORMED EIGENVECTORS -! IN ITS FIRST M COLUMNS. -! -! NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. -! -! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -! -! ------------------------------------------------------------------ -! - IF (M .EQ. 0) GO TO 140 - IF (N .EQ. 1) GO TO 140 -! - DO 120 I = 2, N - L = I - 1 - IZ = (I * L) / 2 - IK = IZ + I - H = A(IK) - IF (H .EQ. 0.0D+00) GO TO 120 -! - DO 100 J = 1, M - S = -DDOT(L,A(IZ+1),1,Z(1,J),1) -! -! ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** - S = (S / H) / H -! - CALL DAXPY(L,S,A(IZ+1),1,Z(1,J),1) -! - 100 CONTINUE -! - 120 CONTINUE -! - 140 return -! ********** LAST CARD OF TRBAK3 ********** - end subroutine TRBK3B -!----------------------------------------------------------------------------- -!*MODULE EIGEN *DECK TRED3B - subroutine TRED3B(N,NV,A,D,E,E2) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,NV - real(kind=8),DIMENSION(NV) :: A - real(kind=8),DIMENSION(N) :: D,E2 - real(kind=8) :: E(*)!el E(L) - integer :: ii,i,l,iz,k,jk,j,jm1 - real(kind=8) :: h,f,g,scale,dt,hh -! -! THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, -! NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -! -! THIS ROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS -! A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX -! USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. -! -! ON INPUT- -! -! N IS THE ORDER OF THE MATRIX, -! -! NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -! AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, -! -! A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC -! INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL -! ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. -! -! ON OUTPUT- -! -! A CONTAINS INFORMATION ABOUT THE ORTHOGONAL -! TRANSFORMATIONS USED IN THE REDUCTION, -! -! D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, -! -! E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -! MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, -! -! E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -! E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -! -! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -! -! ------------------------------------------------------------------ -! -! ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - IZ = (I * L) / 2 - H = 0.0D+00 - SCALE = 0.0D+00 - IF (L .LT. 1) GO TO 120 -! ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** - DO 100 K = 1, L - IZ = IZ + 1 - D(K) = A(IZ) - SCALE = SCALE + ABS(D(K)) - 100 CONTINUE -! - IF (SCALE .NE. 0.0D+00) GO TO 140 - 120 E(I) = 0.0D+00 - E2(I) = 0.0D+00 - GO TO 280 -! - 140 DO 160 K = 1, L - D(K) = D(K) / SCALE - H = H + D(K) * D(K) - 160 CONTINUE -! - E2(I) = SCALE * SCALE * H - F = D(L) - G = -SIGN(SQRT(H),F) - E(I) = SCALE * G - H = H - F * G - D(L) = F - G - A(IZ) = SCALE * D(L) - IF (L .EQ. 1) GO TO 280 - F = 0.0D+00 -! - JK = 1 - DO 220 J = 1, L - JM1 = J - 1 - DT = D(J) - G = 0.0D+00 -! ********** FORM ELEMENT OF A*U ********** - IF (JM1 .EQ. 0) GO TO 200 - DO 180 K = 1, JM1 - E(K) = E(K) + DT * A(JK) - G = G + D(K) * A(JK) - JK = JK + 1 - 180 CONTINUE - 200 E(J) = G + A(JK) * DT - JK = JK + 1 -! ********** FORM ELEMENT OF P ********** - 220 CONTINUE - F = 0.0D+00 - DO 240 J = 1, L - E(J) = E(J) / H - F = F + E(J) * D(J) - 240 CONTINUE -! - HH = F / (H + H) - JK = 0 -! ********** FORM REDUCED A ********** - DO 260 J = 1, L - F = D(J) - G = E(J) - HH * F - E(J) = G -! - DO 260 K = 1, J - JK = JK + 1 - A(JK) = A(JK) - F * E(K) - G * D(K) - 260 CONTINUE -! - 280 D(I) = A(IZ+1) - A(IZ+1) = SCALE * SQRT(H) - 300 CONTINUE -! - return -! ********** LAST CARD OF TRED3 ********** - end subroutine TRED3B -!----------------------------------------------------------------------------- -! blas.f -!----------------------------------------------------------------------------- -! 10 NOV 94 - MWS - DNRM2: REMOVE FTNCHECK WARNINGS -! 11 JUN 94 - MWS - INCLUDE A COPY OF DGEMV (LEVEL TWO ROUTINE) -! 11 AUG 87 - MWS - SANITIZE FLOATING POINT CONSTANTS IN DNRM2 -! 26 MAR 87 - MWS - USE GENERIC SIGN IN DROTG -! 28 NOV 86 - STE - SUPPLY ALL LEVEL ONE BLAS -! 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS -! -! BASIC LINEAR ALGEBRA SUBPROGRAMS (BLAS) FROM LINPACK (LEVEL 1) -! -! THIS MODULE SHOULD BE COMPILED ONLY IF SPECIALLY CODED -! VERSIONS OF THESE ROUTINES ARE NOT AVAILABLE ON THE TARGET MACHINE -! -!*MODULE BLAS1 *DECK DASUM - real(kind=8) function DASUM(N,DX,INCX) -! -! TAKES THE SUM OF THE ABSOLUTE VALUES. -! JACK DONGARRA, LINPACK, 3/11/78. -! - real(kind=8) :: DX(1),DTEMP - INTEGER :: I,INCX,M,MP1,N,NINCX -! - DASUM = 0.0D+00 - DTEMP = 0.0D+00 - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -! -! CODE FOR INCREMENT NOT EQUAL TO 1 -! - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DTEMP = DTEMP + ABS(DX(I)) - 10 CONTINUE - DASUM = DTEMP - RETURN -! -! CODE FOR INCREMENT EQUAL TO 1 -! -! -! CLEAN-UP LOOP -! - 20 M = MOD(N,6) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + ABS(DX(I)) - 30 CONTINUE - IF( N .LT. 6 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2)) & - + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5)) - 50 CONTINUE - 60 DASUM = DTEMP - return - end function DASUM -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DAXPY - subroutine DAXPY(N,DA,DX,INCX,DY,INCY) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX,INCY - real(kind=8),DIMENSION(1) :: DX,DY - real(kind=8) :: DA -! -! CONSTANT TIMES A VECTOR PLUS A VECTOR. -! DY(I) = DY(I) + DA * DX(I) -! USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer :: ix,iy,i,m,mp1 - IF(N.LE.0)RETURN - IF (DA .EQ. 0.0D+00) RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -! -! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -! NOT EQUAL TO 1 -! - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -! -! CODE FOR BOTH INCREMENTS EQUAL TO 1 -! -! -! CLEAN-UP LOOP -! - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - return - end subroutine DAXPY -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DCOPY - subroutine DCOPY(N,DX,INCX,DY,INCY) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX,INCY - real(kind=8),DIMENSION(*) :: DX,DY -! -! COPIES A VECTOR. -! DY(I) <== DX(I) -! USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer :: ix,iy,m,i,mp1 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -! -! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -! NOT EQUAL TO 1 -! - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -! -! CODE FOR BOTH INCREMENTS EQUAL TO 1 -! -! -! CLEAN-UP LOOP -! - 20 M = MOD(N,7) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DX(I) - 30 CONTINUE - IF( N .LT. 7 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,7 - DY(I) = DX(I) - DY(I + 1) = DX(I + 1) - DY(I + 2) = DX(I + 2) - DY(I + 3) = DX(I + 3) - DY(I + 4) = DX(I + 4) - DY(I + 5) = DX(I + 5) - DY(I + 6) = DX(I + 6) - 50 CONTINUE - return - end subroutine DCOPY -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DDOT - real(kind=8) function DDOT(N,DX,INCX,DY,INCY) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX,INCY - real(kind=8),DIMENSION(1) :: DX,DY -! -! FORMS THE DOT PRODUCT OF TWO VECTORS. -! DOT = DX(I) * DY(I) -! USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer ::ix,iy,m,mp1,i - real(kind=8) :: DTEMP - DDOT = 0.0D+00 - DTEMP = 0.0D+00 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -! -! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -! NOT EQUAL TO 1 -! - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - DDOT = DTEMP - RETURN -! -! CODE FOR BOTH INCREMENTS EQUAL TO 1 -! -! -! CLEAN-UP LOOP -! - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + & - DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - 60 DDOT = DTEMP - return - end function DDOT -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DNRM2 - real(kind=8) function DNRM2(N,DX,INCX) - - INTEGER :: NEXT,N,INCX - real(kind=8) :: DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE - DATA ZERO, ONE /0.0D+00, 1.0D+00/ - - integer :: i,j,nn -! -! EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE -! INCREMENT INCX . -! IF N .LE. 0 RETURN WITH RESULT = 0. -! IF N .GE. 1 THEN INCX MUST BE .GE. 1 -! -! C.L.LAWSON, 1978 JAN 08 -! -! FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE -! HOPEFULLY APPLICABLE TO ALL MACHINES. -! CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. -! CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. -! WHERE -! EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. -! U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) -! V = LARGEST NO. (OVERFLOW LIMIT) -! -! BRIEF OUTLINE OF ALGORITHM.. -! -! PHASE 1 SCANS ZERO COMPONENTS. -! MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO -! MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO -! MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M -! WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. -! -! VALUES FOR CUTLO AND CUTHI.. -! FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER -! DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. -! CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE -! UNIVAC AND DEC AT 2**(-103) -! THUS CUTLO = 2**(-51) = 4.44089E-16 -! CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. -! THUS CUTHI = 2**(63.5) = 1.30438E19 -! CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. -! THUS CUTLO = 2**(-33.5) = 8.23181D-11 -! CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D+19 -! DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / -! DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / - DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / -! - J=0 - IF(N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 -! - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -! BEGIN MAIN LOOP - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -! -! PHASE 1. SUM IS ZERO -! - 50 IF( DX(I) .EQ. ZERO) GO TO 200 - IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 -! -! PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT - GO TO 105 -! -! PREPARE FOR PHASE 4. -! - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = ABS(DX(I)) - GO TO 115 -! -! PHASE 2. SUM IS SMALL. -! SCALE TO AVOID DESTRUCTIVE UNDERFLOW. -! - 70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75 -! -! COMMON CODE FOR PHASES 2 AND 4. -! IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. -! - 110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = ABS(DX(I)) - GO TO 200 -! - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -! -! -! PREPARE FOR PHASE 3. -! - 75 SUM = (SUM * XMAX) * XMAX -! -! -! FOR REAL OR D.P. SET HITEST = CUTHI/N -! FOR COMPLEX SET HITEST = CUTHI/(2*N) -! - 85 HITEST = CUTHI/N -! -! PHASE 3. SUM IS MID-RANGE. NO SCALING. -! - DO 95 J =I,NN,INCX - IF(ABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = SQRT( SUM ) - GO TO 300 -! - 200 CONTINUE - I = I + INCX - IF ( I .LE. NN ) GO TO 20 -! -! END OF MAIN LOOP. -! -! COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. -! - DNRM2 = XMAX * SQRT(SUM) - 300 CONTINUE - return - end function DNRM2 -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DROT - subroutine DROT(N,DX,INCX,DY,INCY,C,S) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX,INCY - real(kind=8),DIMENSION(1) :: DX,DY - real(kind=8) :: C,S -! -! APPLIES A PLANE ROTATION. -! DX(I) = C*DX(I) + S*DY(I) -! DY(I) = -S*DX(I) + C*DY(I) -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer :: ix,iy,i - real(kind=8) :: DTEMP - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -! -! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -! TO 1 -! - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = C*DX(IX) + S*DY(IY) - DY(IY) = C*DY(IY) - S*DX(IX) - DX(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -! -! CODE FOR BOTH INCREMENTS EQUAL TO 1 -! - 20 DO 30 I = 1,N - DTEMP = C*DX(I) + S*DY(I) - DY(I) = C*DY(I) - S*DX(I) - DX(I) = DTEMP - 30 CONTINUE - return - end subroutine DROT -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DROTG - subroutine DROTG(DA,DB,C,S) -! -! CONSTRUCT GIVENS PLANE ROTATION. -! JACK DONGARRA, LINPACK, 3/11/78. -! - real(kind=8) :: DA,DB,C,S,ROE,SCALE,R,Z -! - real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00 -! -!----------------------------------------------------------------------- -! -! - ROE = DB - IF( ABS(DA) .GT. ABS(DB) ) ROE = DA - SCALE = ABS(DA) + ABS(DB) - IF( SCALE .NE. ZERO ) GO TO 10 - C = ONE - S = ZERO - R = ZERO - GO TO 20 -! - 10 R = SCALE*SQRT((DA/SCALE)**2 + (DB/SCALE)**2) - R = SIGN(ONE,ROE)*R - C = DA/R - S = DB/R - 20 Z = ONE - IF( ABS(DA) .GT. ABS(DB) ) Z = S - IF( ABS(DB) .GE. ABS(DA) .AND. C .NE. ZERO ) Z = ONE/C - DA = R - DB = Z - return - end subroutine DROTG -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DSCAL - subroutine DSCAL(N,DA,DX,INCX) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX - real(kind=8),DIMENSION(1) :: DX - real(kind=8) :: DA -! -! SCALES A VECTOR BY A CONSTANT. -! DX(I) = DA * DX(I) -! USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer :: NINCX,m,mp1,i - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -! -! CODE FOR INCREMENT NOT EQUAL TO 1 -! - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -! -! CODE FOR INCREMENT EQUAL TO 1 -! -! -! CLEAN-UP LOOP -! - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - return - end subroutine DSCAL -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK DSWAP - subroutine DSWAP(N,DX,INCX,DY,INCY) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX,INCY - real(kind=8),DIMENSION(1) :: DX,DY -! -! INTERCHANGES TWO VECTORS. -! DX(I) <==> DY(I) -! USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer :: ix,iy,i,m,mp1 - real(kind=8) :: DTEMP - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -! -! CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -! TO 1 -! - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -! -! CODE FOR BOTH INCREMENTS EQUAL TO 1 -! -! -! CLEAN-UP LOOP -! - 20 M = MOD(N,3) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - 30 CONTINUE - IF( N .LT. 3 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I + 1) - DX(I + 1) = DY(I + 1) - DY(I + 1) = DTEMP - DTEMP = DX(I + 2) - DX(I + 2) = DY(I + 2) - DY(I + 2) = DTEMP - 50 CONTINUE - return - end subroutine DSWAP -!----------------------------------------------------------------------------- -!*MODULE BLAS1 *DECK IDAMAX - integer function IDAMAX(N,DX,INCX) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: N,INCX - real(kind=8),DIMENSION(1) :: DX -! -! FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. -! JACK DONGARRA, LINPACK, 3/11/78. -! - integer :: ix,iy,i - real(kind=8) :: RMAX - IDAMAX = 0 - IF( N .LT. 1 ) RETURN - IDAMAX = 1 - IF(N.EQ.1)RETURN - IF(INCX.EQ.1)GO TO 20 -! -! CODE FOR INCREMENT NOT EQUAL TO 1 -! - IX = 1 - RMAX = ABS(DX(1)) - IX = IX + INCX - DO 10 I = 2,N - IF(ABS(DX(IX)).LE.RMAX) GO TO 5 - IDAMAX = I - RMAX = ABS(DX(IX)) - 5 IX = IX + INCX - 10 CONTINUE - RETURN -! -! CODE FOR INCREMENT EQUAL TO 1 -! - 20 RMAX = ABS(DX(1)) - DO 30 I = 2,N - IF(ABS(DX(I)).LE.RMAX) GO TO 30 - IDAMAX = I - RMAX = ABS(DX(I)) - 30 CONTINUE - return - end function IDAMAX -!----------------------------------------------------------------------------- -!*MODULE BLAS *DECK DGEMV - subroutine DGEMV(FORMA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - -! IMPLICIT DOUBLE PRECISION(A-H,O-Z) - integer :: M,N,INCX,INCY,LDA - CHARACTER(len=1) :: FORMA - real(kind=8),DIMENSION(LDA,*) :: A - real(kind=8),DIMENSION(*) :: X,Y - real(kind=8),PARAMETER :: ZERO=0.0D+00, ONE=1.0D+00 - real(kind=8) :: ALPHA,BETA - integer :: i,locy -! -! CLONE OF -DGEMV- WRITTEN BY MIKE SCHMIDT -! - LOCY = 1 - IF(FORMA.EQ.'T') GO TO 200 -! -! Y = ALPHA * A * X + BETA * Y -! - IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN - DO 110 I=1,M - Y(LOCY) = DDOT(N,A(I,1),LDA,X,INCX) - LOCY = LOCY+INCY - 110 CONTINUE - ELSE - DO 120 I=1,M - Y(LOCY) = ALPHA*DDOT(N,A(I,1),LDA,X,INCX) + BETA*Y(LOCY) - LOCY = LOCY+INCY - 120 CONTINUE - END IF - RETURN -! -! Y = ALPHA * A-TRANSPOSE * X + BETA * Y -! - 200 CONTINUE - IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN - DO 210 I=1,N - Y(LOCY) = DDOT(M,A(1,I),1,X,INCX) - LOCY = LOCY+INCY - 210 CONTINUE - ELSE - DO 220 I=1,N - Y(LOCY) = ALPHA*DDOT(M,A(1,I),1,X,INCX) + BETA*Y(LOCY) - LOCY = LOCY+INCY - 220 CONTINUE - END IF - return - end subroutine DGEMV -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module MD_calc diff --git a/source/unres/minim.F90 b/source/unres/minim.F90 new file mode 100644 index 0000000..4305640 --- /dev/null +++ b/source/unres/minim.F90 @@ -0,0 +1,6508 @@ + module minimm +!----------------------------------------------------------------------------- + use io_units + use names + use math +! use MPI_data + use geometry_data + use energy_data + use control_data + use minim_data + use geometry +! use csa_data +! use energy + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! cored.f +!----------------------------------------------------------------------------- + subroutine assst(iv, liv, lv, v) +! +! *** assess candidate step (***sol version 2.3) *** +! + integer :: liv, l,lv + integer :: iv(liv) + real(kind=8) :: v(lv) +! +! *** purpose *** +! +! this subroutine is called by an unconstrained minimization +! routine to assess the next candidate step. it may recommend one +! of several courses of action, such as accepting the step, recom- +! puting it using the same or a new quadratic model, or halting due +! to convergence or false convergence. see the return code listing +! below. +! +!-------------------------- parameter usage -------------------------- +! +! iv (i/o) integer parameter and scratch vector -- see description +! below of iv values referenced. +! liv (in) length of iv array. +! lv (in) length of v array. +! v (i/o) real parameter and scratch vector -- see description +! below of v values referenced. +! +! *** iv values referenced *** +! +! iv(irc) (i/o) on input for the first step tried in a new iteration, +! iv(irc) should be set to 3 or 4 (the value to which it is +! set when step is definitely to be accepted). on input +! after step has been recomputed, iv(irc) should be +! unchanged since the previous return of assst. +! on output, iv(irc) is a return code having one of the +! following values... +! 1 = switch models or try smaller step. +! 2 = switch models or accept step. +! 3 = accept step and determine v(radfac) by gradient +! tests. +! 4 = accept step, v(radfac) has been determined. +! 5 = recompute step (using the same model). +! 6 = recompute step with radius = v(lmaxs) but do not +! evaulate the objective function. +! 7 = x-convergence (see v(xctol)). +! 8 = relative function convergence (see v(rfctol)). +! 9 = both x- and relative function convergence. +! 10 = absolute function convergence (see v(afctol)). +! 11 = singular convergence (see v(lmaxs)). +! 12 = false convergence (see v(xftol)). +! 13 = iv(irc) was out of range on input. +! return code i has precdence over i+1 for i = 9, 10, 11. +! iv(mlstgd) (i/o) saved value of iv(model). +! iv(model) (i/o) on input, iv(model) should be an integer identifying +! the current quadratic model of the objective function. +! if a previous step yielded a better function reduction, +! then iv(model) will be set to iv(mlstgd) on output. +! iv(nfcall) (in) invocation count for the objective function. +! iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest +! function reduction this iteration. iv(nfgcal) remains +! unchanged until a function reduction is obtained. +! iv(radinc) (i/o) the number of radius increases (or minus the number +! of decreases) so far this iteration. +! iv(restor) (out) set to 1 if v(f) has been restored and x should be +! restored to its initial value, to 2 if x should be saved, +! to 3 if x should be restored from the saved value, and to +! 0 otherwise. +! iv(stage) (i/o) count of the number of models tried so far in the +! current iteration. +! iv(stglim) (in) maximum number of models to consider. +! iv(switch) (out) set to 0 unless a new model is being tried and it +! gives a smaller function value than the previous model, +! in which case assst sets iv(switch) = 1. +! iv(toobig) (in) is nonzero if step was too big (e.g. if it caused +! overflow). +! iv(xirc) (i/o) value that iv(irc) would have in the absence of +! convergence, false convergence, and oversized steps. +! +! *** v values referenced *** +! +! v(afctol) (in) absolute function convergence tolerance. if the +! absolute value of the current function value v(f) is less +! than v(afctol), then assst returns with iv(irc) = 10. +! v(decfac) (in) factor by which to decrease radius when iv(toobig) is +! nonzero. +! v(dstnrm) (in) the 2-norm of d*step. +! v(dstsav) (i/o) value of v(dstnrm) on saved step. +! v(dst0) (in) the 2-norm of d times the newton step (when defined, +! i.e., for v(nreduc) .ge. 0). +! v(f) (i/o) on both input and output, v(f) is the objective func- +! tion value at x. if x is restored to a previous value, +! then v(f) is restored to the corresponding value. +! v(fdif) (out) the function reduction v(f0) - v(f) (for the output +! value of v(f) if an earlier step gave a bigger function +! decrease, and for the input value of v(f) otherwise). +! v(flstgd) (i/o) saved value of v(f). +! v(f0) (in) objective function value at start of iteration. +! v(gtslst) (i/o) value of v(gtstep) on saved step. +! v(gtstep) (in) inner product between step and gradient. +! v(incfac) (in) minimum factor by which to increase radius. +! v(lmaxs) (in) maximum reasonable step size (and initial step bound). +! if the actual function decrease is no more than twice +! what was predicted, if a return with iv(irc) = 7, 8, 9, +! or 10 does not occur, if v(dstnrm) .gt. v(lmaxs), and if +! v(preduc) .le. v(sctol) * abs(v(f0)), then assst re- +! turns with iv(irc) = 11. if so doing appears worthwhile, +! then assst repeats this test with v(preduc) computed for +! a step of length v(lmaxs) (by a return with iv(irc) = 6). +! v(nreduc) (i/o) function reduction predicted by quadratic model for +! newton step. if assst is called with iv(irc) = 6, i.e., +! if v(preduc) has been computed with radius = v(lmaxs) for +! use in the singular convervence test, then v(nreduc) is +! set to -v(preduc) before the latter is restored. +! v(plstgd) (i/o) value of v(preduc) on saved step. +! v(preduc) (i/o) function reduction predicted by quadratic model for +! current step. +! v(radfac) (out) factor to be used in determining the new radius, +! which should be v(radfac)*dst, where dst is either the +! output value of v(dstnrm) or the 2-norm of +! diag(newd)*step for the output value of step and the +! updated version, newd, of the scale vector d. for +! iv(irc) = 3, v(radfac) = 1.0 is returned. +! v(rdfcmn) (in) minimum value for v(radfac) in terms of the input +! value of v(dstnrm) -- suggested value = 0.1. +! v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0. +! v(reldx) (in) scaled relative change in x caused by step, computed +! (e.g.) by function reldst as +! max (d(i)*abs(x(i)-x0(i)), 1 .le. i .le. p) / +! max (d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p). +! v(rfctol) (in) relative function convergence tolerance. if the +! actual function reduction is at most twice what was pre- +! dicted and v(nreduc) .le. v(rfctol)*abs(v(f0)), then +! assst returns with iv(irc) = 8 or 9. +! v(stppar) (in) marquardt parameter -- 0 means full newton step. +! v(tuner1) (in) tuning constant used to decide if the function +! reduction was much less than expected. suggested +! value = 0.1. +! v(tuner2) (in) tuning constant used to decide if the function +! reduction was large enough to accept step. suggested +! value = 10**-4. +! v(tuner3) (in) tuning constant used to decide if the radius +! should be increased. suggested value = 0.75. +! v(xctol) (in) x-convergence criterion. if step is a newton step +! (v(stppar) = 0) having v(reldx) .le. v(xctol) and giving +! at most twice the predicted function decrease, then +! assst returns iv(irc) = 7 or 9. +! v(xftol) (in) false convergence tolerance. if step gave no or only +! a small function decrease and v(reldx) .le. v(xftol), +! then assst returns with iv(irc) = 12. +! +!------------------------------- notes ------------------------------- +! +! *** application and usage restrictions *** +! +! this routine is called as part of the nl2sol (nonlinear +! least-squares) package. it may be used in any unconstrained +! minimization solver that uses dogleg, goldfeld-quandt-trotter, +! or levenberg-marquardt steps. +! +! *** algorithm notes *** +! +! see (1) for further discussion of the assessing and model +! switching strategies. while nl2sol considers only two models, +! assst is designed to handle any number of models. +! +! *** usage notes *** +! +! on the first call of an iteration, only the i/o variables +! step, x, iv(irc), iv(model), v(f), v(dstnrm), v(gtstep), and +! v(preduc) need have been initialized. between calls, no i/o +! values execpt step, x, iv(model), v(f) and the stopping toler- +! ances should be changed. +! after a return for convergence or false convergence, one can +! change the stopping tolerances and call assst again, in which +! case the stopping tests will be repeated. +! +! *** references *** +! +! (1) dennis, j.e., jr., gay, d.m., and welsch, r.e. (1981), +! an adaptive nonlinear least-squares algorithm, +! acm trans. math. software, vol. 7, no. 3. +! +! (2) powell, m.j.d. (1970) a fortran subroutine for solving +! systems of nonlinear algebraic equations, in numerical +! methods for nonlinear algebraic equations, edited by +! p. rabinowitz, gordon and breach, london. +! +! *** history *** +! +! john dennis designed much of this routine, starting with +! ideas in (2). roy welsch suggested the model switching strategy. +! david gay and stephen peters cast this subroutine into a more +! portable form (winter 1977), and david gay cast it into its +! present form (fall 1978). +! +! *** general *** +! +! this subroutine was written in connection with research +! supported by the national science foundation under grants +! mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and +! mcs-7906671. +! +!------------------------ external quantities ------------------------ +! +! *** no external functions and subroutines *** +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dabs, dmax1 +!/ +! *** no common blocks *** +! +!-------------------------- local variables -------------------------- +! + logical :: goodx + integer :: i, nfc + real(kind=8) :: emax, emaxs, gts, rfac1, xmax +!el real(kind=8) :: half, one, onep2, two, zero +! +! *** subscripts for iv and v *** +! +!el integer :: afctol, decfac, dstnrm, dstsav, dst0, f, fdif, flstgd, f0,& +!el gtslst, gtstep, incfac, irc, lmaxs, mlstgd, model, nfcall,& +!el nfgcal, nreduc, plstgd, preduc, radfac, radinc, rdfcmn,& +!el rdfcmx, reldx, restor, rfctol, sctol, stage, stglim,& +!el stppar, switch, toobig, tuner1, tuner2, tuner3, xctol,& +!el xftol, xirc +! +! +! *** data initializations *** +! +!/6 +! data half/0.5d+0/, one/1.d+0/, onep2/1.2d+0/, two/2.d+0/, +! 1 zero/0.d+0/ +!/7 + real(kind=8),parameter :: half=0.5d+0, one=1.d+0, onep2=1.2d+0, two=2.d+0,& + zero=0.d+0 +!/ +! +!/6 +! data irc/29/, mlstgd/32/, model/5/, nfcall/6/, nfgcal/7/, +! 1 radinc/8/, restor/9/, stage/10/, stglim/11/, switch/12/, +! 2 toobig/2/, xirc/13/ +!/7 + integer,parameter :: irc=29, mlstgd=32, model=5, nfcall=6, nfgcal=7,& + radinc=8, restor=9, stage=10, stglim=11, switch=12,& + toobig=2, xirc=13 +!/ +!/6 +! data afctol/31/, decfac/22/, dstnrm/2/, dst0/3/, dstsav/18/, +! 1 f/10/, fdif/11/, flstgd/12/, f0/13/, gtslst/14/, gtstep/4/, +! 2 incfac/23/, lmaxs/36/, nreduc/6/, plstgd/15/, preduc/7/, +! 3 radfac/16/, rdfcmn/24/, rdfcmx/25/, reldx/17/, rfctol/32/, +! 4 sctol/37/, stppar/5/, tuner1/26/, tuner2/27/, tuner3/28/, +! 5 xctol/33/, xftol/34/ +!/7 + integer,parameter :: afctol=31, decfac=22, dstnrm=2, dst0=3, dstsav=18,& + f=10, fdif=11, flstgd=12, f0=13, gtslst=14, gtstep=4,& + incfac=23, lmaxs=36, nreduc=6, plstgd=15, preduc=7,& + radfac=16, rdfcmn=24, rdfcmx=25, reldx=17, rfctol=32,& + sctol=37, stppar=5, tuner1=26, tuner2=27, tuner3=28,& + xctol=33, xftol=34 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! + nfc = iv(nfcall) + iv(switch) = 0 + iv(restor) = 0 + rfac1 = one + goodx = .true. + i = iv(irc) + if (i .ge. 1 .and. i .le. 12) & + go to (20,30,10,10,40,280,220,220,220,220,220,170), i + iv(irc) = 13 + go to 999 +! +! *** initialize for new iteration *** +! + 10 iv(stage) = 1 + iv(radinc) = 0 + v(flstgd) = v(f0) + if (iv(toobig) .eq. 0) go to 110 + iv(stage) = -1 + iv(xirc) = i + go to 60 +! +! *** step was recomputed with new model or smaller radius *** +! *** first decide which *** +! + 20 if (iv(model) .ne. iv(mlstgd)) go to 30 +! *** old model retained, smaller radius tried *** +! *** do not consider any more new models this iteration *** + iv(stage) = iv(stglim) + iv(radinc) = -1 + go to 110 +! +! *** a new model is being tried. decide whether to keep it. *** +! + 30 iv(stage) = iv(stage) + 1 +! +! *** now we add the possibiltiy that step was recomputed with *** +! *** the same model, perhaps because of an oversized step. *** +! + 40 if (iv(stage) .gt. 0) go to 50 +! +! *** step was recomputed because it was too big. *** +! + if (iv(toobig) .ne. 0) go to 60 +! +! *** restore iv(stage) and pick up where we left off. *** +! + iv(stage) = -iv(stage) + i = iv(xirc) + go to (20, 30, 110, 110, 70), i +! + 50 if (iv(toobig) .eq. 0) go to 70 +! +! *** handle oversize step *** +! + if (iv(radinc) .gt. 0) go to 80 + iv(stage) = -iv(stage) + iv(xirc) = iv(irc) +! + 60 v(radfac) = v(decfac) + iv(radinc) = iv(radinc) - 1 + iv(irc) = 5 + iv(restor) = 1 + go to 999 +! + 70 if (v(f) .lt. v(flstgd)) go to 110 +! +! *** the new step is a loser. restore old model. *** +! + if (iv(model) .eq. iv(mlstgd)) go to 80 + iv(model) = iv(mlstgd) + iv(switch) = 1 +! +! *** restore step, etc. only if a previous step decreased v(f). +! + 80 if (v(flstgd) .ge. v(f0)) go to 110 + iv(restor) = 1 + v(f) = v(flstgd) + v(preduc) = v(plstgd) + v(gtstep) = v(gtslst) + if (iv(switch) .eq. 0) rfac1 = v(dstnrm) / v(dstsav) + v(dstnrm) = v(dstsav) + nfc = iv(nfgcal) + goodx = .false. +! + 110 v(fdif) = v(f0) - v(f) + if (v(fdif) .gt. v(tuner2) * v(preduc)) go to 140 + if(iv(radinc).gt.0) go to 140 +! +! *** no (or only a trivial) function decrease +! *** -- so try new model or smaller radius +! + if (v(f) .lt. v(f0)) go to 120 + iv(mlstgd) = iv(model) + v(flstgd) = v(f) + v(f) = v(f0) + iv(restor) = 1 + go to 130 + 120 iv(nfgcal) = nfc + 130 iv(irc) = 1 + if (iv(stage) .lt. iv(stglim)) go to 160 + iv(irc) = 5 + iv(radinc) = iv(radinc) - 1 + go to 160 +! +! *** nontrivial function decrease achieved *** +! + 140 iv(nfgcal) = nfc + rfac1 = one + v(dstsav) = v(dstnrm) + if (v(fdif) .gt. v(preduc)*v(tuner1)) go to 190 +! +! *** decrease was much less than predicted -- either change models +! *** or accept step with decreased radius. +! + if (iv(stage) .ge. iv(stglim)) go to 150 +! *** consider switching models *** + iv(irc) = 2 + go to 160 +! +! *** accept step with decreased radius *** +! + 150 iv(irc) = 4 +! +! *** set v(radfac) to fletcher*s decrease factor *** +! + 160 iv(xirc) = iv(irc) + emax = v(gtstep) + v(fdif) + v(radfac) = half * rfac1 + if (emax .lt. v(gtstep)) v(radfac) = rfac1 * dmax1(v(rdfcmn),& + half * v(gtstep)/emax) +! +! *** do false convergence test *** +! + 170 if (v(reldx) .le. v(xftol)) go to 180 + iv(irc) = iv(xirc) + if (v(f) .lt. v(f0)) go to 200 + go to 230 +! + 180 iv(irc) = 12 + go to 240 +! +! *** handle good function decrease *** +! + 190 if (v(fdif) .lt. (-v(tuner3) * v(gtstep))) go to 210 +! +! *** increasing radius looks worthwhile. see if we just +! *** recomputed step with a decreased radius or restored step +! *** after recomputing it with a larger radius. +! + if (iv(radinc) .lt. 0) go to 210 + if (iv(restor) .eq. 1) go to 210 +! +! *** we did not. try a longer step unless this was a newton +! *** step. + + v(radfac) = v(rdfcmx) + gts = v(gtstep) + if (v(fdif) .lt. (half/v(radfac) - one) * gts) & + v(radfac) = dmax1(v(incfac), half*gts/(gts + v(fdif))) + iv(irc) = 4 + if (v(stppar) .eq. zero) go to 230 + if (v(dst0) .ge. zero .and. (v(dst0) .lt. two*v(dstnrm) & + .or. v(nreduc) .lt. onep2*v(fdif))) go to 230 +! *** step was not a newton step. recompute it with +! *** a larger radius. + iv(irc) = 5 + iv(radinc) = iv(radinc) + 1 +! +! *** save values corresponding to good step *** +! + 200 v(flstgd) = v(f) + iv(mlstgd) = iv(model) + if (iv(restor) .ne. 1) iv(restor) = 2 + v(dstsav) = v(dstnrm) + iv(nfgcal) = nfc + v(plstgd) = v(preduc) + v(gtslst) = v(gtstep) + go to 230 +! +! *** accept step with radius unchanged *** +! + 210 v(radfac) = one + iv(irc) = 3 + go to 230 +! +! *** come here for a restart after convergence *** +! + 220 iv(irc) = iv(xirc) + if (v(dstsav) .ge. zero) go to 240 + iv(irc) = 12 + go to 240 +! +! *** perform convergence tests *** +! + 230 iv(xirc) = iv(irc) + 240 if (iv(restor) .eq. 1 .and. v(flstgd) .lt. v(f0)) iv(restor) = 3 + if (half * v(fdif) .gt. v(preduc)) go to 999 + emax = v(rfctol) * dabs(v(f0)) + emaxs = v(sctol) * dabs(v(f0)) + if (v(dstnrm) .gt. v(lmaxs) .and. v(preduc) .le. emaxs) & + iv(irc) = 11 + if (v(dst0) .lt. zero) go to 250 + i = 0 + if ((v(nreduc) .gt. zero .and. v(nreduc) .le. emax) .or. & + (v(nreduc) .eq. zero .and. v(preduc) .eq. zero)) i = 2 + if (v(stppar) .eq. zero .and. v(reldx) .le. v(xctol) & + .and. goodx) i = i + 1 + if (i .gt. 0) iv(irc) = i + 6 +! +! *** consider recomputing step of length v(lmaxs) for singular +! *** convergence test. +! + 250 if (iv(irc) .gt. 5 .and. iv(irc) .ne. 12) go to 999 + if (v(dstnrm) .gt. v(lmaxs)) go to 260 + if (v(preduc) .ge. emaxs) go to 999 + if (v(dst0) .le. zero) go to 270 + if (half * v(dst0) .le. v(lmaxs)) go to 999 + go to 270 + 260 if (half * v(dstnrm) .le. v(lmaxs)) go to 999 + xmax = v(lmaxs) / v(dstnrm) + if (xmax * (two - xmax) * v(preduc) .ge. emaxs) go to 999 + 270 if (v(nreduc) .lt. zero) go to 290 +! +! *** recompute v(preduc) for use in singular convergence test *** +! + v(gtslst) = v(gtstep) + v(dstsav) = v(dstnrm) + if (iv(irc) .eq. 12) v(dstsav) = -v(dstsav) + v(plstgd) = v(preduc) + i = iv(restor) + iv(restor) = 2 + if (i .eq. 3) iv(restor) = 0 + iv(irc) = 6 + go to 999 +! +! *** perform singular convergence test with recomputed v(preduc) *** +! + 280 v(gtstep) = v(gtslst) + v(dstnrm) = dabs(v(dstsav)) + iv(irc) = iv(xirc) + if (v(dstsav) .le. zero) iv(irc) = 12 + v(nreduc) = -v(preduc) + v(preduc) = v(plstgd) + iv(restor) = 3 + 290 if (-v(nreduc) .le. v(sctol) * dabs(v(f0))) iv(irc) = 11 +! + 999 return +! +! *** last card of assst follows *** + end subroutine assst +!----------------------------------------------------------------------------- + subroutine deflt(alg, iv, liv, lv, v) +! +! *** supply ***sol (version 2.3) default values to iv and v *** +! +! *** alg = 1 means regression constants. +! *** alg = 2 means general unconstrained optimization constants. +! + integer :: liv, l,lv + integer :: alg, iv(liv) + real(kind=8) :: v(lv) +! +!el external imdcon, vdflt +!el integer imdcon +! imdcon... returns machine-dependent integer constants. +! vdflt.... provides default values to v. +! + integer :: miv, m + integer :: miniv(2), minv(2) +! +! *** subscripts for iv *** +! +!el integer algsav, covprt, covreq, dtype, hc, ierr, inith, inits, +!el 1 ipivot, ivneed, lastiv, lastv, lmat, mxfcal, mxiter, +!el 2 nfcov, ngcov, nvdflt, outlev, parprt, parsav, perm, +!el 3 prunit, qrtyp, rdreq, rmat, solprt, statpr, vneed, +!el 4 vsave, x0prt +! +! *** iv subscript values *** +! +!/6 +! data algsav/51/, covprt/14/, covreq/15/, dtype/16/, hc/71/, +! 1 ierr/75/, inith/25/, inits/25/, ipivot/76/, ivneed/3/, +! 2 lastiv/44/, lastv/45/, lmat/42/, mxfcal/17/, mxiter/18/, +! 3 nfcov/52/, ngcov/53/, nvdflt/50/, outlev/19/, parprt/20/, +! 4 parsav/49/, perm/58/, prunit/21/, qrtyp/80/, rdreq/57/, +! 5 rmat/78/, solprt/22/, statpr/23/, vneed/4/, vsave/60/, +! 6 x0prt/24/ +!/7 + integer,parameter :: algsav=51, covprt=14, covreq=15, dtype=16, hc=71,& + ierr=75, inith=25, inits=25, ipivot=76, ivneed=3,& + lastiv=44, lastv=45, lmat=42, mxfcal=17, mxiter=18,& + nfcov=52, ngcov=53, nvdflt=50, outlev=19, parprt=20,& + parsav=49, perm=58, prunit=21, qrtyp=80, rdreq=57,& + rmat=78, solprt=22, statpr=23, vneed=4, vsave=60,& + x0prt=24 +!/ + data miniv(1)/80/, miniv(2)/59/, minv(1)/98/, minv(2)/71/ +!el local variables + integer :: mv +! +!------------------------------- body -------------------------------- +! + if (alg .lt. 1 .or. alg .gt. 2) go to 40 + miv = miniv(alg) + if (liv .lt. miv) go to 20 + mv = minv(alg) + if (lv .lt. mv) go to 30 + call vdflt(alg, lv, v) + iv(1) = 12 + iv(algsav) = alg + iv(ivneed) = 0 + iv(lastiv) = miv + iv(lastv) = mv + iv(lmat) = mv + 1 + iv(mxfcal) = 200 + iv(mxiter) = 150 + iv(outlev) = 1 + iv(parprt) = 1 + iv(perm) = miv + 1 + iv(prunit) = imdcon(1) + iv(solprt) = 1 + iv(statpr) = 1 + iv(vneed) = 0 + iv(x0prt) = 1 +! + if (alg .ge. 2) go to 10 +! +! *** regression values +! + iv(covprt) = 3 + iv(covreq) = 1 + iv(dtype) = 1 + iv(hc) = 0 + iv(ierr) = 0 + iv(inits) = 0 + iv(ipivot) = 0 + iv(nvdflt) = 32 + iv(parsav) = 67 + iv(qrtyp) = 1 + iv(rdreq) = 3 + iv(rmat) = 0 + iv(vsave) = 58 + go to 999 +! +! *** general optimization values +! + 10 iv(dtype) = 0 + iv(inith) = 1 + iv(nfcov) = 0 + iv(ngcov) = 0 + iv(nvdflt) = 25 + iv(parsav) = 47 + go to 999 +! + 20 iv(1) = 15 + go to 999 +! + 30 iv(1) = 16 + go to 999 +! + 40 iv(1) = 67 +! + 999 return +! *** last card of deflt follows *** + end subroutine deflt +!----------------------------------------------------------------------------- + real(kind=8) function dotprd(p,x,y) +! +! *** return the inner product of the p-vectors x and y. *** +! + integer :: p + real(kind=8) :: x(p), y(p) +! + integer :: i +!el real(kind=8) :: one, zero + real(kind=8) :: sqteta, t +!/+ +!el real(kind=8) :: dmax1, dabs +!/ +!el external rmdcon +!el real(kind=8) :: rmdcon +! +! *** rmdcon(2) returns a machine-dependent constant, sqteta, which +! *** is slightly larger than the smallest positive number that +! *** can be squared without underflowing. +! +!/6 +! data one/1.d+0/, sqteta/0.d+0/, zero/0.d+0/ +!/7 + real(kind=8),parameter :: one=1.d+0, zero=0.d+0 + data sqteta/0.d+0/ +!/ +! + dotprd = zero + if (p .le. 0) go to 999 +!rc if (sqteta .eq. zero) sqteta = rmdcon(2) + do 20 i = 1, p +!rc t = dmax1(dabs(x(i)), dabs(y(i))) +!rc if (t .gt. one) go to 10 +!rc if (t .lt. sqteta) go to 20 +!rc t = (x(i)/sqteta)*y(i) +!rc if (dabs(t) .lt. sqteta) go to 20 + 10 dotprd = dotprd + x(i)*y(i) + 20 continue +! + 999 return +! *** last card of dotprd follows *** + end function dotprd +!----------------------------------------------------------------------------- + subroutine itsum(d, g, iv, liv, lv, p, v, x) +! +! *** print iteration summary for ***sol (version 2.3) *** +! +! *** parameter declarations *** +! + integer :: liv, lv, p + integer :: iv(liv) + real(kind=8) :: d(p), g(p), v(lv), x(p) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! *** local variables *** +! + integer :: alg, i, iv1, m, nf, ng, ol, pu +!/6 +! real model1(6), model2(6) +!/7 + character(len=4) :: model1(6), model2(6) +!/ + real(kind=8) :: nreldf, oldf, preldf, reldf !el, zero +! +! *** intrinsic functions *** +!/+ +!el integer :: iabs +!el real(kind=8) :: dabs, dmax1 +!/ +! *** no external functions or subroutines *** +! +! *** subscripts for iv and v *** +! +!el integer algsav, dstnrm, f, fdif, f0, needhd, nfcall, nfcov, ngcov, +!el 1 ngcall, niter, nreduc, outlev, preduc, prntit, prunit, +!el 2 reldx, solprt, statpr, stppar, sused, x0prt +! +! *** iv subscript values *** +! +!/6 +! data algsav/51/, needhd/36/, nfcall/6/, nfcov/52/, ngcall/30/, +! 1 ngcov/53/, niter/31/, outlev/19/, prntit/39/, prunit/21/, +! 2 solprt/22/, statpr/23/, sused/64/, x0prt/24/ +!/7 + integer,parameter :: algsav=51, needhd=36, nfcall=6, nfcov=52, ngcall=30,& + ngcov=53, niter=31, outlev=19, prntit=39, prunit=21,& + solprt=22, statpr=23, sused=64, x0prt=24 +!/ +! +! *** v subscript values *** +! +!/6 +! data dstnrm/2/, f/10/, f0/13/, fdif/11/, nreduc/6/, preduc/7/, +! 1 reldx/17/, stppar/5/ +!/7 + integer,parameter :: dstnrm=2, f=10, f0=13, fdif=11, nreduc=6, preduc=7,& + reldx=17, stppar=5 +!/ +! +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +!/6 +! data model1(1)/4h /, model1(2)/4h /, model1(3)/4h /, +! 1 model1(4)/4h /, model1(5)/4h g /, model1(6)/4h s /, +! 2 model2(1)/4h g /, model2(2)/4h s /, model2(3)/4hg-s /, +! 3 model2(4)/4hs-g /, model2(5)/4h-s-g/, model2(6)/4h-g-s/ +!/7 + data model1/' ',' ',' ',' ',' g ',' s '/,& + model2/' g ',' s ','g-s ','s-g ','-s-g','-g-s'/ +!/ +! +!------------------------------- body -------------------------------- +! + pu = iv(prunit) + if (pu .eq. 0) go to 999 + iv1 = iv(1) + if (iv1 .gt. 62) iv1 = iv1 - 51 + ol = iv(outlev) + alg = iv(algsav) + if (iv1 .lt. 2 .or. iv1 .gt. 15) go to 370 + if (iv1 .ge. 12) go to 120 + if (iv1 .eq. 2 .and. iv(niter) .eq. 0) go to 390 + if (ol .eq. 0) go to 120 + if (iv1 .ge. 10 .and. iv(prntit) .eq. 0) go to 120 + if (iv1 .gt. 2) go to 10 + iv(prntit) = iv(prntit) + 1 + if (iv(prntit) .lt. iabs(ol)) go to 999 + 10 nf = iv(nfcall) - iabs(iv(nfcov)) + iv(prntit) = 0 + reldf = zero + preldf = zero + oldf = dmax1(dabs(v(f0)), dabs(v(f))) + if (oldf .le. zero) go to 20 + reldf = v(fdif) / oldf + preldf = v(preduc) / oldf + 20 if (ol .gt. 0) go to 60 +! +! *** print short summary line *** +! + if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,30) + 30 format(/10h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx,& + 2x,13hmodel stppar) + if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,40) + 40 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx,& + 3x,6hstppar) + iv(needhd) = 0 + if (alg .eq. 2) go to 50 + m = iv(sused) + write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx),& + model1(m), model2(m), v(stppar) + go to 120 +! + 50 write(pu,110) iv(niter), nf, v(f), reldf, preldf, v(reldx),& + v(stppar) + go to 120 +! +! *** print long summary line *** +! + 60 if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,70) + 70 format(/11h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx,& + 2x,13hmodel stppar,2x,6hd*step,2x,7hnpreldf) + if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,80) + 80 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx,& + 3x,6hstppar,3x,6hd*step,3x,7hnpreldf) + iv(needhd) = 0 + nreldf = zero + if (oldf .gt. zero) nreldf = v(nreduc) / oldf + if (alg .eq. 2) go to 90 + m = iv(sused) + write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx),& + model1(m), model2(m), v(stppar), v(dstnrm), nreldf + go to 120 +! + 90 write(pu,110) iv(niter), nf, v(f), reldf, preldf,& + v(reldx), v(stppar), v(dstnrm), nreldf + 100 format(i6,i5,d10.3,2d9.2,d8.1,a3,a4,2d8.1,d9.2) + 110 format(i6,i5,d11.3,2d10.2,3d9.1,d10.2) +! + 120 if (iv(statpr) .lt. 0) go to 430 + go to (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310,& + 330, 350, 520), iv1 +! + 130 write(pu,140) + 140 format(/26h ***** x-convergence *****) + go to 430 +! + 150 write(pu,160) + 160 format(/42h ***** relative function convergence *****) + go to 430 +! + 170 write(pu,180) + 180 format(/49h ***** x- and relative function convergence *****) + go to 430 +! + 190 write(pu,200) + 200 format(/42h ***** absolute function convergence *****) + go to 430 +! + 210 write(pu,220) + 220 format(/33h ***** singular convergence *****) + go to 430 +! + 230 write(pu,240) + 240 format(/30h ***** false convergence *****) + go to 430 +! + 250 write(pu,260) + 260 format(/38h ***** function evaluation limit *****) + go to 430 +! + 270 write(pu,280) + 280 format(/28h ***** iteration limit *****) + go to 430 +! + 290 write(pu,300) + 300 format(/18h ***** stopx *****) + go to 430 +! + 310 write(pu,320) + 320 format(/44h ***** initial f(x) cannot be computed *****) +! + go to 390 +! + 330 write(pu,340) + 340 format(/37h ***** bad parameters to assess *****) + go to 999 +! + 350 write(pu,360) + 360 format(/43h ***** gradient could not be computed *****) + if (iv(niter) .gt. 0) go to 480 + go to 390 +! + 370 write(pu,380) iv(1) + 380 format(/14h ***** iv(1) =,i5,6h *****) + go to 999 +! +! *** initial call on itsum *** +! + 390 if (iv(x0prt) .ne. 0) write(pu,400) (i, x(i), d(i), i = 1, p) + 400 format(/23h i initial x(i),8x,4hd(i)//(1x,i5,d17.6,d14.3)) +! *** the following are to avoid undefined variables when the +! *** function evaluation limit is 1... + v(dstnrm) = zero + v(fdif) = zero + v(nreduc) = zero + v(preduc) = zero + v(reldx) = zero + if (iv1 .ge. 12) go to 999 + iv(needhd) = 0 + iv(prntit) = 0 + if (ol .eq. 0) go to 999 + if (ol .lt. 0 .and. alg .eq. 1) write(pu,30) + if (ol .lt. 0 .and. alg .eq. 2) write(pu,40) + if (ol .gt. 0 .and. alg .eq. 1) write(pu,70) + if (ol .gt. 0 .and. alg .eq. 2) write(pu,80) + if (alg .eq. 1) write(pu,410) v(f) + if (alg .eq. 2) write(pu,420) v(f) + 410 format(/11h 0 1,d10.3) +!365 format(/11h 0 1,e11.3) + 420 format(/11h 0 1,d11.3) + go to 999 +! +! *** print various information requested on solution *** +! + 430 iv(needhd) = 1 + if (iv(statpr) .eq. 0) go to 480 + oldf = dmax1(dabs(v(f0)), dabs(v(f))) + preldf = zero + nreldf = zero + if (oldf .le. zero) go to 440 + preldf = v(preduc) / oldf + nreldf = v(nreduc) / oldf + 440 nf = iv(nfcall) - iv(nfcov) + ng = iv(ngcall) - iv(ngcov) + write(pu,450) v(f), v(reldx), nf, ng, preldf, nreldf + 450 format(/9h function,d17.6,8h reldx,d17.3/12h func. evals,& + i8,9x,11hgrad. evals,i8/7h preldf,d16.3,6x,7hnpreldf,d15.3) +! + if (iv(nfcov) .gt. 0) write(pu,460) iv(nfcov) + 460 format(/1x,i4,50h extra func. evals for covariance and diagnostics.) + if (iv(ngcov) .gt. 0) write(pu,470) iv(ngcov) + 470 format(1x,i4,50h extra grad. evals for covariance and diagnostics.) +! + 480 if (iv(solprt) .eq. 0) go to 999 + iv(needhd) = 1 + write(pu,490) + 490 format(/22h i final x(i),8x,4hd(i),10x,4hg(i)/) + do 500 i = 1, p + write(pu,510) i, x(i), d(i), g(i) + 500 continue + 510 format(1x,i5,d16.6,2d14.3) + go to 999 +! + 520 write(pu,530) + 530 format(/24h inconsistent dimensions) + 999 return +! *** last card of itsum follows *** + end subroutine itsum +!----------------------------------------------------------------------------- + subroutine litvmu(n, x, l, y) +! +! *** solve (l**t)*x = y, where l is an n x n lower triangular +! *** matrix stored compactly by rows. x and y may occupy the same +! *** storage. *** +! + integer :: n +!al real(kind=8) :: x(n), l(1), y(n) + real(kind=8) :: x(n), l(n*(n+1)/2), y(n) + integer :: i, ii, ij, im1, i0, j, np1 + real(kind=8) :: xi !el, zero +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +! + do 10 i = 1, n + 10 x(i) = y(i) + np1 = n + 1 + i0 = n*(n+1)/2 + do 30 ii = 1, n + i = np1 - ii + xi = x(i)/l(i0) + x(i) = xi + if (i .le. 1) go to 999 + i0 = i0 - i + if (xi .eq. zero) go to 30 + im1 = i - 1 + do 20 j = 1, im1 + ij = i0 + j + x(j) = x(j) - xi*l(ij) + 20 continue + 30 continue + 999 return +! *** last card of litvmu follows *** + end subroutine litvmu +!----------------------------------------------------------------------------- + subroutine livmul(n, x, l, y) +! +! *** solve l*x = y, where l is an n x n lower triangular +! *** matrix stored compactly by rows. x and y may occupy the same +! *** storage. *** +! + integer :: n +!al real(kind=8) :: x(n), l(1), y(n) + real(kind=8) :: x(n), l(n*(n+1)/2), y(n) +!el external dotprd +!el real(kind=8) :: dotprd + integer :: i, j, k + real(kind=8) :: t !el, zero +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +! + do 10 k = 1, n + if (y(k) .ne. zero) go to 20 + x(k) = zero + 10 continue + go to 999 + 20 j = k*(k+1)/2 + x(k) = y(k) / l(j) + if (k .ge. n) go to 999 + k = k + 1 + do 30 i = k, n + t = dotprd(i-1, l(j+1), x) + j = j + i + x(i) = (y(i) - t)/l(j) + 30 continue + 999 return +! *** last card of livmul follows *** + end subroutine livmul +!----------------------------------------------------------------------------- + subroutine parck(alg, d, iv, liv, lv, n, v) +! +! *** check ***sol (version 2.3) parameters, print changed values *** +! +! *** alg = 1 for regression, alg = 2 for general unconstrained opt. +! + integer :: alg, liv, lv, n + integer :: iv(liv) + real(kind=8) :: d(n), v(lv) +! +!el external rmdcon, vcopy, vdflt +!el real(kind=8) :: rmdcon +! rmdcon -- returns machine-dependent constants. +! vcopy -- copies one vector to another. +! vdflt -- supplies default parameter values to v alone. +!/+ +!el integer :: max0 +!/ +! +! *** local variables *** +! + integer :: i, ii, iv1, j, k, l, m, miv1, miv2, ndfalt, parsv1, pu + integer :: ijmp, jlim(2), miniv(2), ndflt(2) +!/6 +! integer varnm(2), sh(2) +! real cngd(3), dflt(3), vn(2,34), which(3) +!/7 + character(len=1) :: varnm(2), sh(2) + character(len=4) :: cngd(3), dflt(3), vn(2,34), which(3) +!/ + real(kind=8) :: big, machep, tiny, vk, vm(34), vx(34), zero +! +! *** iv and v subscripts *** +! +!el integer algsav, dinit, dtype, dtype0, epslon, inits, ivneed, +!el 1 lastiv, lastv, lmat, nextiv, nextv, nvdflt, oldn, +!el 2 parprt, parsav, perm, prunit, vneed +! +! +!/6 +! data algsav/51/, dinit/38/, dtype/16/, dtype0/54/, epslon/19/, +! 1 inits/25/, ivneed/3/, lastiv/44/, lastv/45/, lmat/42/, +! 2 nextiv/46/, nextv/47/, nvdflt/50/, oldn/38/, parprt/20/, +! 3 parsav/49/, perm/58/, prunit/21/, vneed/4/ +!/7 + integer,parameter :: algsav=51, dinit=38, dtype=16, dtype0=54, epslon=19,& + inits=25, ivneed=3, lastiv=44, lastv=45, lmat=42,& + nextiv=46, nextv=47, nvdflt=50, oldn=38, parprt=20,& + parsav=49, perm=58, prunit=21, vneed=4 + save big, machep, tiny +!/ +! + data big/0.d+0/, machep/-1.d+0/, tiny/1.d+0/, zero/0.d+0/ +!/6 +! data vn(1,1),vn(2,1)/4hepsl,4hon../ +! data vn(1,2),vn(2,2)/4hphmn,4hfc../ +! data vn(1,3),vn(2,3)/4hphmx,4hfc../ +! data vn(1,4),vn(2,4)/4hdecf,4hac../ +! data vn(1,5),vn(2,5)/4hincf,4hac../ +! data vn(1,6),vn(2,6)/4hrdfc,4hmn../ +! data vn(1,7),vn(2,7)/4hrdfc,4hmx../ +! data vn(1,8),vn(2,8)/4htune,4hr1../ +! data vn(1,9),vn(2,9)/4htune,4hr2../ +! data vn(1,10),vn(2,10)/4htune,4hr3../ +! data vn(1,11),vn(2,11)/4htune,4hr4../ +! data vn(1,12),vn(2,12)/4htune,4hr5../ +! data vn(1,13),vn(2,13)/4hafct,4hol../ +! data vn(1,14),vn(2,14)/4hrfct,4hol../ +! data vn(1,15),vn(2,15)/4hxcto,4hl.../ +! data vn(1,16),vn(2,16)/4hxfto,4hl.../ +! data vn(1,17),vn(2,17)/4hlmax,4h0.../ +! data vn(1,18),vn(2,18)/4hlmax,4hs.../ +! data vn(1,19),vn(2,19)/4hscto,4hl.../ +! data vn(1,20),vn(2,20)/4hdini,4ht.../ +! data vn(1,21),vn(2,21)/4hdtin,4hit../ +! data vn(1,22),vn(2,22)/4hd0in,4hit../ +! data vn(1,23),vn(2,23)/4hdfac,4h..../ +! data vn(1,24),vn(2,24)/4hdltf,4hdc../ +! data vn(1,25),vn(2,25)/4hdltf,4hdj../ +! data vn(1,26),vn(2,26)/4hdelt,4ha0../ +! data vn(1,27),vn(2,27)/4hfuzz,4h..../ +! data vn(1,28),vn(2,28)/4hrlim,4hit../ +! data vn(1,29),vn(2,29)/4hcosm,4hin../ +! data vn(1,30),vn(2,30)/4hhube,4hrc../ +! data vn(1,31),vn(2,31)/4hrspt,4hol../ +! data vn(1,32),vn(2,32)/4hsigm,4hin../ +! data vn(1,33),vn(2,33)/4heta0,4h..../ +! data vn(1,34),vn(2,34)/4hbias,4h..../ +!/7 + data vn(1,1),vn(2,1)/'epsl','on..'/ + data vn(1,2),vn(2,2)/'phmn','fc..'/ + data vn(1,3),vn(2,3)/'phmx','fc..'/ + data vn(1,4),vn(2,4)/'decf','ac..'/ + data vn(1,5),vn(2,5)/'incf','ac..'/ + data vn(1,6),vn(2,6)/'rdfc','mn..'/ + data vn(1,7),vn(2,7)/'rdfc','mx..'/ + data vn(1,8),vn(2,8)/'tune','r1..'/ + data vn(1,9),vn(2,9)/'tune','r2..'/ + data vn(1,10),vn(2,10)/'tune','r3..'/ + data vn(1,11),vn(2,11)/'tune','r4..'/ + data vn(1,12),vn(2,12)/'tune','r5..'/ + data vn(1,13),vn(2,13)/'afct','ol..'/ + data vn(1,14),vn(2,14)/'rfct','ol..'/ + data vn(1,15),vn(2,15)/'xcto','l...'/ + data vn(1,16),vn(2,16)/'xfto','l...'/ + data vn(1,17),vn(2,17)/'lmax','0...'/ + data vn(1,18),vn(2,18)/'lmax','s...'/ + data vn(1,19),vn(2,19)/'scto','l...'/ + data vn(1,20),vn(2,20)/'dini','t...'/ + data vn(1,21),vn(2,21)/'dtin','it..'/ + data vn(1,22),vn(2,22)/'d0in','it..'/ + data vn(1,23),vn(2,23)/'dfac','....'/ + data vn(1,24),vn(2,24)/'dltf','dc..'/ + data vn(1,25),vn(2,25)/'dltf','dj..'/ + data vn(1,26),vn(2,26)/'delt','a0..'/ + data vn(1,27),vn(2,27)/'fuzz','....'/ + data vn(1,28),vn(2,28)/'rlim','it..'/ + data vn(1,29),vn(2,29)/'cosm','in..'/ + data vn(1,30),vn(2,30)/'hube','rc..'/ + data vn(1,31),vn(2,31)/'rspt','ol..'/ + data vn(1,32),vn(2,32)/'sigm','in..'/ + data vn(1,33),vn(2,33)/'eta0','....'/ + data vn(1,34),vn(2,34)/'bias','....'/ +!/ +! + data vm(1)/1.0d-3/, vm(2)/-0.99d+0/, vm(3)/1.0d-3/, vm(4)/1.0d-2/,& + vm(5)/1.2d+0/, vm(6)/1.d-2/, vm(7)/1.2d+0/, vm(8)/0.d+0/,& + vm(9)/0.d+0/, vm(10)/1.d-3/, vm(11)/-1.d+0/, vm(13)/0.d+0/,& + vm(15)/0.d+0/, vm(16)/0.d+0/, vm(19)/0.d+0/, vm(20)/-10.d+0/,& + vm(21)/0.d+0/, vm(22)/0.d+0/, vm(23)/0.d+0/, vm(27)/1.01d+0/,& + vm(28)/1.d+10/, vm(30)/0.d+0/, vm(31)/0.d+0/, vm(32)/0.d+0/,& + vm(34)/0.d+0/ + data vx(1)/0.9d+0/, vx(2)/-1.d-3/, vx(3)/1.d+1/, vx(4)/0.8d+0/,& + vx(5)/1.d+2/, vx(6)/0.8d+0/, vx(7)/1.d+2/, vx(8)/0.5d+0/,& + vx(9)/0.5d+0/, vx(10)/1.d+0/, vx(11)/1.d+0/, vx(14)/0.1d+0/,& + vx(15)/1.d+0/, vx(16)/1.d+0/, vx(19)/1.d+0/, vx(23)/1.d+0/,& + vx(24)/1.d+0/, vx(25)/1.d+0/, vx(26)/1.d+0/, vx(27)/1.d+10/,& + vx(29)/1.d+0/, vx(31)/1.d+0/, vx(32)/1.d+0/, vx(33)/1.d+0/,& + vx(34)/1.d+0/ +! +!/6 +! data varnm(1)/1hp/, varnm(2)/1hn/, sh(1)/1hs/, sh(2)/1hh/ +! data cngd(1),cngd(2),cngd(3)/4h---c,4hhang,4hed v/, +! 1 dflt(1),dflt(2),dflt(3)/4hnond,4hefau,4hlt v/ +!/7 + data varnm(1)/'p'/, varnm(2)/'n'/, sh(1)/'s'/, sh(2)/'h'/ + data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/,& + dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/ +!/ + data ijmp/33/, jlim(1)/0/, jlim(2)/24/, ndflt(1)/32/, ndflt(2)/25/ + data miniv(1)/80/, miniv(2)/59/ +! +!............................... body ................................ +! + pu = 0 + if (prunit .le. liv) pu = iv(prunit) + if (alg .lt. 1 .or. alg .gt. 2) go to 340 + if (iv(1) .eq. 0) call deflt(alg, iv, liv, lv, v) + iv1 = iv(1) + if (iv1 .ne. 13 .and. iv1 .ne. 12) go to 10 + miv1 = miniv(alg) + if (perm .le. liv) miv1 = max0(miv1, iv(perm) - 1) + if (ivneed .le. liv) miv2 = miv1 + max0(iv(ivneed), 0) + if (lastiv .le. liv) iv(lastiv) = miv2 + if (liv .lt. miv1) go to 300 + iv(ivneed) = 0 + iv(lastv) = max0(iv(vneed), 0) + iv(lmat) - 1 + iv(vneed) = 0 + if (liv .lt. miv2) go to 300 + if (lv .lt. iv(lastv)) go to 320 + 10 if (alg .eq. iv(algsav)) go to 30 + if (pu .ne. 0) write(pu,20) alg, iv(algsav) + 20 format(/39h the first parameter to deflt should be,i3,& + 12h rather than,i3) + iv(1) = 82 + go to 999 + 30 if (iv1 .lt. 12 .or. iv1 .gt. 14) go to 60 + if (n .ge. 1) go to 50 + iv(1) = 81 + if (pu .eq. 0) go to 999 + write(pu,40) varnm(alg), n + 40 format(/8h /// bad,a1,2h =,i5) + go to 999 + 50 if (iv1 .ne. 14) iv(nextiv) = iv(perm) + if (iv1 .ne. 14) iv(nextv) = iv(lmat) + if (iv1 .eq. 13) go to 999 + k = iv(parsav) - epslon + call vdflt(alg, lv-k, v(k+1)) + iv(dtype0) = 2 - alg + iv(oldn) = n + which(1) = dflt(1) + which(2) = dflt(2) + which(3) = dflt(3) + go to 110 + 60 if (n .eq. iv(oldn)) go to 80 + iv(1) = 17 + if (pu .eq. 0) go to 999 + write(pu,70) varnm(alg), iv(oldn), n + 70 format(/5h /// ,1a1,14h changed from ,i5,4h to ,i5) + go to 999 +! + 80 if (iv1 .le. 11 .and. iv1 .ge. 1) go to 100 + iv(1) = 80 + if (pu .ne. 0) write(pu,90) iv1 + 90 format(/13h /// iv(1) =,i5,28h should be between 0 and 14.) + go to 999 +! + 100 which(1) = cngd(1) + which(2) = cngd(2) + which(3) = cngd(3) +! + 110 if (iv1 .eq. 14) iv1 = 12 + if (big .gt. tiny) go to 120 + tiny = rmdcon(1) + machep = rmdcon(3) + big = rmdcon(6) + vm(12) = machep + vx(12) = big + vx(13) = big + vm(14) = machep + vm(17) = tiny + vx(17) = big + vm(18) = tiny + vx(18) = big + vx(20) = big + vx(21) = big + vx(22) = big + vm(24) = machep + vm(25) = machep + vm(26) = machep + vx(28) = rmdcon(5) + vm(29) = machep + vx(30) = big + vm(33) = machep + 120 m = 0 + i = 1 + j = jlim(alg) + k = epslon + ndfalt = ndflt(alg) + do 150 l = 1, ndfalt + vk = v(k) + if (vk .ge. vm(i) .and. vk .le. vx(i)) go to 140 + m = k + if (pu .ne. 0) write(pu,130) vn(1,i), vn(2,i), k, vk,& + vm(i), vx(i) + 130 format(/6h /// ,2a4,5h.. v(,i2,3h) =,d11.3,7h should,& + 11h be between,d11.3,4h and,d11.3) + 140 k = k + 1 + i = i + 1 + if (i .eq. j) i = ijmp + 150 continue +! + if (iv(nvdflt) .eq. ndfalt) go to 170 + iv(1) = 51 + if (pu .eq. 0) go to 999 + write(pu,160) iv(nvdflt), ndfalt + 160 format(/13h iv(nvdflt) =,i5,13h rather than ,i5) + go to 999 + 170 if ((iv(dtype) .gt. 0 .or. v(dinit) .gt. zero) .and. iv1 .eq. 12) & + go to 200 + do 190 i = 1, n + if (d(i) .gt. zero) go to 190 + m = 18 + if (pu .ne. 0) write(pu,180) i, d(i) + 180 format(/8h /// d(,i3,3h) =,d11.3,19h should be positive) + 190 continue + 200 if (m .eq. 0) go to 210 + iv(1) = m + go to 999 +! + 210 if (pu .eq. 0 .or. iv(parprt) .eq. 0) go to 999 + if (iv1 .ne. 12 .or. iv(inits) .eq. alg-1) go to 230 + m = 1 + write(pu,220) sh(alg), iv(inits) + 220 format(/22h nondefault values..../5h init,a1,14h..... iv(25) =,& + i3) + 230 if (iv(dtype) .eq. iv(dtype0)) go to 250 + if (m .eq. 0) write(pu,260) which + m = 1 + write(pu,240) iv(dtype) + 240 format(20h dtype..... iv(16) =,i3) + 250 i = 1 + j = jlim(alg) + k = epslon + l = iv(parsav) + ndfalt = ndflt(alg) + do 290 ii = 1, ndfalt + if (v(k) .eq. v(l)) go to 280 + if (m .eq. 0) write(pu,260) which + 260 format(/1h ,3a4,9halues..../) + m = 1 + write(pu,270) vn(1,i), vn(2,i), k, v(k) + 270 format(1x,2a4,5h.. v(,i2,3h) =,d15.7) + 280 k = k + 1 + l = l + 1 + i = i + 1 + if (i .eq. j) i = ijmp + 290 continue +! + iv(dtype0) = iv(dtype) + parsv1 = iv(parsav) + call vcopy(iv(nvdflt), v(parsv1), v(epslon)) + go to 999 +! + 300 iv(1) = 15 + if (pu .eq. 0) go to 999 + write(pu,310) liv, miv2 + 310 format(/10h /// liv =,i5,17h must be at least,i5) + if (liv .lt. miv1) go to 999 + if (lv .lt. iv(lastv)) go to 320 + go to 999 +! + 320 iv(1) = 16 + if (pu .eq. 0) go to 999 + write(pu,330) lv, iv(lastv) + 330 format(/9h /// lv =,i5,17h must be at least,i5) + go to 999 +! + 340 iv(1) = 67 + if (pu .eq. 0) go to 999 + write(pu,350) alg + 350 format(/10h /// alg =,i5,15h must be 1 or 2) +! + 999 return +! *** last card of parck follows *** + end subroutine parck +!----------------------------------------------------------------------------- + real(kind=8) function reldst(p, d, x, x0) +! +! *** compute and return relative difference between x and x0 *** +! *** nl2sol version 2.2 *** +! + integer :: p + real(kind=8) :: d(p), x(p), x0(p) +!/+ +!el real(kind=8) :: dabs +!/ + integer :: i + real(kind=8) :: emax, t, xmax !el, zero +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +! + emax = zero + xmax = zero + do 10 i = 1, p + t = dabs(d(i) * (x(i) - x0(i))) + if (emax .lt. t) emax = t + t = d(i) * (dabs(x(i)) + dabs(x0(i))) + if (xmax .lt. t) xmax = t + 10 continue + reldst = zero + if (xmax .gt. zero) reldst = emax / xmax + 999 return +! *** last card of reldst follows *** + end function reldst +!----------------------------------------------------------------------------- + subroutine vaxpy(p, w, a, x, y) +! +! *** set w = a*x + y -- w, x, y = p-vectors, a = scalar *** +! + integer :: p + real(kind=8) :: a, w(p), x(p), y(p) +! + integer :: i +! + do 10 i = 1, p + 10 w(i) = a*x(i) + y(i) + return + end subroutine vaxpy +!----------------------------------------------------------------------------- + subroutine vcopy(p, y, x) +! +! *** set y = x, where x and y are p-vectors *** +! + integer :: p + real(kind=8) :: x(p), y(p) +! + integer :: i +! + do 10 i = 1, p + 10 y(i) = x(i) + return + end subroutine vcopy +!----------------------------------------------------------------------------- + subroutine vdflt(alg, lv, v) +! +! *** supply ***sol (version 2.3) default values to v *** +! +! *** alg = 1 means regression constants. +! *** alg = 2 means general unconstrained optimization constants. +! + integer :: alg, l,lv + real(kind=8) :: v(lv) +!/+ +!el real(kind=8) :: dmax1 +!/ +!el external rmdcon +!el real(kind=8) :: rmdcon +! rmdcon... returns machine-dependent constants +! + real(kind=8) :: machep, mepcrt, sqteps !el one, three +! +! *** subscripts for v *** +! +!el integer afctol, bias, cosmin, decfac, delta0, dfac, dinit, dltfdc, +!el 1 dltfdj, dtinit, d0init, epslon, eta0, fuzz, huberc, +!el 2 incfac, lmax0, lmaxs, phmnfc, phmxfc, rdfcmn, rdfcmx, +!el 3 rfctol, rlimit, rsptol, sctol, sigmin, tuner1, tuner2, +!el 4 tuner3, tuner4, tuner5, xctol, xftol +! +!/6 +! data one/1.d+0/, three/3.d+0/ +!/7 + real(kind=8),parameter :: one=1.d+0, three=3.d+0 +!/ +! +! *** v subscript values *** +! +!/6 +! data afctol/31/, bias/43/, cosmin/47/, decfac/22/, delta0/44/, +! 1 dfac/41/, dinit/38/, dltfdc/42/, dltfdj/43/, dtinit/39/, +! 2 d0init/40/, epslon/19/, eta0/42/, fuzz/45/, huberc/48/, +! 3 incfac/23/, lmax0/35/, lmaxs/36/, phmnfc/20/, phmxfc/21/, +! 4 rdfcmn/24/, rdfcmx/25/, rfctol/32/, rlimit/46/, rsptol/49/, +! 5 sctol/37/, sigmin/50/, tuner1/26/, tuner2/27/, tuner3/28/, +! 6 tuner4/29/, tuner5/30/, xctol/33/, xftol/34/ +!/7 + integer,parameter :: afctol=31, bias=43, cosmin=47, decfac=22, delta0=44,& + dfac=41, dinit=38, dltfdc=42, dltfdj=43, dtinit=39,& + d0init=40, epslon=19, eta0=42, fuzz=45, huberc=48,& + incfac=23, lmax0=35, lmaxs=36, phmnfc=20, phmxfc=21,& + rdfcmn=24, rdfcmx=25, rfctol=32, rlimit=46, rsptol=49,& + sctol=37, sigmin=50, tuner1=26, tuner2=27, tuner3=28,& + tuner4=29, tuner5=30, xctol=33, xftol=34 +!/ +! +!------------------------------- body -------------------------------- +! + machep = rmdcon(3) + v(afctol) = 1.d-20 + if (machep .gt. 1.d-10) v(afctol) = machep**2 + v(decfac) = 0.5d+0 + sqteps = rmdcon(4) + v(dfac) = 0.6d+0 + v(delta0) = sqteps + v(dtinit) = 1.d-6 + mepcrt = machep ** (one/three) + v(d0init) = 1.d+0 + v(epslon) = 0.1d+0 + v(incfac) = 2.d+0 + v(lmax0) = 1.d+0 + v(lmaxs) = 1.d+0 + v(phmnfc) = -0.1d+0 + v(phmxfc) = 0.1d+0 + v(rdfcmn) = 0.1d+0 + v(rdfcmx) = 4.d+0 + v(rfctol) = dmax1(1.d-10, mepcrt**2) + v(sctol) = v(rfctol) + v(tuner1) = 0.1d+0 + v(tuner2) = 1.d-4 + v(tuner3) = 0.75d+0 + v(tuner4) = 0.5d+0 + v(tuner5) = 0.75d+0 + v(xctol) = sqteps + v(xftol) = 1.d+2 * machep +! + if (alg .ge. 2) go to 10 +! +! *** regression values +! + v(cosmin) = dmax1(1.d-6, 1.d+2 * machep) + v(dinit) = 0.d+0 + v(dltfdc) = mepcrt + v(dltfdj) = sqteps + v(fuzz) = 1.5d+0 + v(huberc) = 0.7d+0 + v(rlimit) = rmdcon(5) + v(rsptol) = 1.d-3 + v(sigmin) = 1.d-4 + go to 999 +! +! *** general optimization values +! + 10 v(bias) = 0.8d+0 + v(dinit) = -1.0d+0 + v(eta0) = 1.0d+3 * machep +! + 999 return +! *** last card of vdflt follows *** + end subroutine vdflt +!----------------------------------------------------------------------------- + subroutine vscopy(p, y, s) +! +! *** set p-vector y to scalar s *** +! + integer :: p + real(kind=8) :: s, y(p) +! + integer :: i +! + do 10 i = 1, p + 10 y(i) = s + return + end subroutine vscopy +!----------------------------------------------------------------------------- + real(kind=8) function v2norm(p, x) +! +! *** return the 2-norm of the p-vector x, taking *** +! *** care to avoid the most likely underflows. *** +! + integer :: p + real(kind=8) :: x(p) +! + integer :: i, j + real(kind=8) :: r, scale, sqteta, t, xi !el, one, zero +!/+ +!el real(kind=8) :: dabs, dsqrt +!/ +!el external rmdcon +!el real(kind=8) :: rmdcon +! +!/6 +! data one/1.d+0/, zero/0.d+0/ +!/7 + real(kind=8),parameter :: one=1.d+0, zero=0.d+0 + save sqteta +!/ + data sqteta/0.d+0/ +! + if (p .gt. 0) go to 10 + v2norm = zero + go to 999 + 10 do 20 i = 1, p + if (x(i) .ne. zero) go to 30 + 20 continue + v2norm = zero + go to 999 +! + 30 scale = dabs(x(i)) + if (i .lt. p) go to 40 + v2norm = scale + go to 999 + 40 t = one + if (sqteta .eq. zero) sqteta = rmdcon(2) +! +! *** sqteta is (slightly larger than) the square root of the +! *** smallest positive floating point number on the machine. +! *** the tests involving sqteta are done to prevent underflows. +! + j = i + 1 + do 60 i = j, p + xi = dabs(x(i)) + if (xi .gt. scale) go to 50 + r = xi / scale + if (r .gt. sqteta) t = t + r*r + go to 60 + 50 r = scale / xi + if (r .le. sqteta) r = zero + t = one + t * r*r + scale = xi + 60 continue +! + v2norm = scale * dsqrt(t) + 999 return +! *** last card of v2norm follows *** + end function v2norm +!----------------------------------------------------------------------------- + subroutine humsl(n,d,x,calcf,calcgh,iv,liv,lv,v,uiparm,urparm,ufparm) +! +! *** minimize general unconstrained objective function using *** +! *** (analytic) gradient and hessian provided by the caller. *** +! + integer :: liv, lv, n + integer :: iv(liv), uiparm(1) + real(kind=8) :: d(n), x(n), v(lv), urparm(1) + real(kind=8),external :: ufparm +! dimension v(78 + n*(n+12)), uiparm(*), urparm(*) + external :: calcf, calcgh +! +!------------------------------ discussion --------------------------- +! +! this routine is like sumsl, except that the subroutine para- +! meter calcg of sumsl (which computes the gradient of the objec- +! tive function) is replaced by the subroutine parameter calcgh, +! which computes both the gradient and (lower triangle of the) +! hessian of the objective function. the calling sequence is... +! call calcgh(n, x, nf, g, h, uiparm, urparm, ufparm) +! parameters n, x, nf, g, uiparm, urparm, and ufparm are the same +! as for sumsl, while h is an array of length n*(n+1)/2 in which +! calcgh must store the lower triangle of the hessian at x. start- +! ing at h(1), calcgh must store the hessian entries in the order +! (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... +! the value printed (by itsum) in the column labelled stppar +! is the levenberg-marquardt used in computing the current step. +! zero means a full newton step. if the special case described in +! ref. 1 is detected, then stppar is negated. the value printed +! in the column labelled npreldf is zero if the current hessian +! is not positive definite. +! it sometimes proves worthwhile to let d be determined from the +! diagonal of the hessian matrix by setting iv(dtype) = 1 and +! v(dinit) = 0. the following iv and v components are relevant... +! +! iv(dtol)..... iv(59) gives the starting subscript in v of the dtol +! array used when d is updated. (iv(dtol) can be +! initialized by calling humsl with iv(1) = 13.) +! iv(dtype).... iv(16) tells how the scale vector d should be chosen. +! iv(dtype) .le. 0 means that d should not be updated, and +! iv(dtype) .ge. 1 means that d should be updated as +! described below with v(dfac). default = 0. +! v(dfac)..... v(41) and the dtol and d0 arrays (see v(dtinit) and +! v(d0init)) are used in updating the scale vector d when +! iv(dtype) .gt. 0. (d is initialized according to +! v(dinit), described in sumsl.) let +! d1(i) = max(sqrt(abs(h(i,i))), v(dfac)*d(i)), +! where h(i,i) is the i-th diagonal element of the current +! hessian. if iv(dtype) = 1, then d(i) is set to d1(i) +! unless d1(i) .lt. dtol(i), in which case d(i) is set to +! max(d0(i), dtol(i)). +! if iv(dtype) .ge. 2, then d is updated during the first +! iteration as for iv(dtype) = 1 (after any initialization +! due to v(dinit)) and is left unchanged thereafter. +! default = 0.6. +! v(dtinit)... v(39), if positive, is the value to which all components +! of the dtol array (see v(dfac)) are initialized. if +! v(dtinit) = 0, then it is assumed that the caller has +! stored dtol in v starting at v(iv(dtol)). +! default = 10**-6. +! v(d0init)... v(40), if positive, is the value to which all components +! of the d0 vector (see v(dfac)) are initialized. if +! v(dfac) = 0, then it is assumed that the caller has +! stored d0 in v starting at v(iv(dtol)+n). default = 1.0. +! +! *** reference *** +! +! 1. gay, d.m. (1981), computing optimal locally constrained steps, +! siam j. sci. statist. comput. 2, pp. 186-197. +!. +! *** general *** +! +! coded by david m. gay (winter 1980). revised sept. 1982. +! this subroutine was written in connection with research supported +! in part by the national science foundation under grants +! mcs-7600324 and mcs-7906671. +! +!---------------------------- declarations --------------------------- +! +!el external deflt, humit +! +! deflt... provides default input values for iv and v. +! humit... reverse-communication routine that does humsl algorithm. +! + integer :: g1, h1, iv1, lh, nf + real(kind=8) :: f +! +! *** subscripts for iv *** +! +!el integer g, h, nextv, nfcall, nfgcal, toobig, vneed +! +!/6 +! data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, h/56/, toobig/2/, +! 1 vneed/4/ +!/7 + integer,parameter :: nextv=47, nfcall=6, nfgcal=7, g=28, h=56,& + toobig=2,vneed=4 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! + lh = n * (n + 1) / 2 + if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) + if (iv(1) .eq. 12 .or. iv(1) .eq. 13) & + iv(vneed) = iv(vneed) + n*(n+3)/2 + iv1 = iv(1) + if (iv1 .eq. 14) go to 10 + if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 + g1 = 1 + h1 = 1 + if (iv1 .eq. 12) iv(1) = 13 + go to 20 +! + 10 g1 = iv(g) + h1 = iv(h) +! + 20 call humit(d, f, v(g1), v(h1), iv, lh, liv, lv, n, v, x) + if (iv(1) - 2) 30, 40, 50 +! + 30 nf = iv(nfcall) + call calcf(n, x, nf, f, uiparm, urparm, ufparm) + if (nf .le. 0) iv(toobig) = 1 + go to 20 +! + 40 call calcgh(n, x, iv(nfgcal), v(g1), v(h1), uiparm, urparm,& + ufparm) + go to 20 +! + 50 if (iv(1) .ne. 14) go to 999 +! +! *** storage allocation +! + iv(g) = iv(nextv) + iv(h) = iv(g) + n + iv(nextv) = iv(h) + n*(n+1)/2 + if (iv1 .ne. 13) go to 10 +! + 999 return +! *** last card of humsl follows *** + end subroutine humsl +!----------------------------------------------------------------------------- + subroutine humit(d, fx, g, h, iv, lh, liv, lv, n, v, x) +! +! *** carry out humsl (unconstrained minimization) iterations, using +! *** hessian matrix provided by the caller. +! +!el use control + use control, only:stopx + +! *** parameter declarations *** +! + integer :: lh, liv, lv, n + integer :: iv(liv) + real(kind=8) :: d(n), fx, g(n), h(lh), v(lv), x(n) +! +!-------------------------- parameter usage -------------------------- +! +! d.... scale vector. +! fx... function value. +! g.... gradient vector. +! h.... lower triangle of the hessian, stored rowwise. +! iv... integer value array. +! lh... length of h = p*(p+1)/2. +! liv.. length of iv (at least 60). +! lv... length of v (at least 78 + n*(n+21)/2). +! n.... number of variables (components in x and g). +! v.... floating-point value array. +! x.... parameter vector. +! +! *** discussion *** +! +! parameters iv, n, v, and x are the same as the corresponding +! ones to humsl (which see), except that v can be shorter (since +! the part of v that humsl uses for storing g and h is not needed). +! moreover, compared with humsl, iv(1) may have the two additional +! output values 1 and 2, which are explained below, as is the use +! of iv(toobig) and iv(nfgcal). the value iv(g), which is an +! output value from humsl, is not referenced by humit or the +! subroutines it calls. +! +! iv(1) = 1 means the caller should set fx to f(x), the function value +! at x, and call humit again, having changed none of the +! other parameters. an exception occurs if f(x) cannot be +! computed (e.g. if overflow would occur), which may happen +! because of an oversized step. in this case the caller +! should set iv(toobig) = iv(2) to 1, which will cause +! humit to ignore fx and try a smaller step. the para- +! meter nf that humsl passes to calcf (for possible use by +! calcgh) is a copy of iv(nfcall) = iv(6). +! iv(1) = 2 means the caller should set g to g(x), the gradient of f at +! x, and h to the lower triangle of h(x), the hessian of f +! at x, and call humit again, having changed none of the +! other parameters except perhaps the scale vector d. +! the parameter nf that humsl passes to calcg is +! iv(nfgcal) = iv(7). if g(x) and h(x) cannot be evaluated, +! then the caller may set iv(nfgcal) to 0, in which case +! humit will return with iv(1) = 65. +! note -- humit overwrites h with the lower triangle +! of diag(d)**-1 * h(x) * diag(d)**-1. +!. +! *** general *** +! +! coded by david m. gay (winter 1980). revised sept. 1982. +! this subroutine was written in connection with research supported +! in part by the national science foundation under grants +! mcs-7600324 and mcs-7906671. +! +! (see sumsl and humsl for references.) +! +!+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ +! +! *** local variables *** +! + integer :: dg1, dummy, i, j, k, l, lstgst, nn1o2, step1,& + temp1, w1, x01 + real(kind=8) :: t +! +! *** constants *** +! +!el real(kind=8) :: one, onep2, zero +! +! *** no intrinsic functions *** +! +! *** external functions and subroutines *** +! +!el external assst, deflt, dotprd, dupdu, gqtst, itsum, parck, +!el 1 reldst, slvmul, stopx, vaxpy, vcopy, vscopy, v2norm +!el logical stopx +!el real(kind=8) :: dotprd, reldst, v2norm +! +! assst.... assesses candidate step. +! deflt.... provides default iv and v input values. +! dotprd... returns inner product of two vectors. +! dupdu.... updates scale vector d. +! gqtst.... computes optimally locally constrained step. +! itsum.... prints iteration summary and info on initial and final x. +! parck.... checks validity of input iv and v values. +! reldst... computes v(reldx) = relative step size. +! slvmul... multiplies symmetric matrix times vector, given the lower +! triangle of the matrix. +! stopx.... returns .true. if the break key has been pressed. +! vaxpy.... computes scalar times one vector plus another. +! vcopy.... copies one vector to another. +! vscopy... sets all elements of a vector to a scalar. +! v2norm... returns the 2-norm of a vector. +! +! *** subscripts for iv and v *** +! +!el integer cnvcod, dg, dgnorm, dinit, dstnrm, dtinit, dtol, +!el 1 dtype, d0init, f, f0, fdif, gtstep, incfac, irc, kagqt, +!el 2 lmat, lmax0, lmaxs, mode, model, mxfcal, mxiter, nextv, +!el 3 nfcall, nfgcal, ngcall, niter, preduc, radfac, radinc, +!el 4 radius, rad0, reldx, restor, step, stglim, stlstg, stppar, +!el 5 toobig, tuner4, tuner5, vneed, w, xirc, x0 +! +! *** iv subscript values *** +! +!/6 +! data cnvcod/55/, dg/37/, dtol/59/, dtype/16/, irc/29/, kagqt/33/, +! 1 lmat/42/, mode/35/, model/5/, mxfcal/17/, mxiter/18/, +! 2 nextv/47/, nfcall/6/, nfgcal/7/, ngcall/30/, niter/31/, +! 3 radinc/8/, restor/9/, step/40/, stglim/11/, stlstg/41/, +! 4 toobig/2/, vneed/4/, w/34/, xirc/13/, x0/43/ +!/7 + integer,parameter :: cnvcod=55, dg=37, dtol=59, dtype=16, irc=29, kagqt=33,& + lmat=42, mode=35, model=5, mxfcal=17, mxiter=18,& + nextv=47, nfcall=6, nfgcal=7, ngcall=30, niter=31,& + radinc=8, restor=9, step=40, stglim=11, stlstg=41,& + toobig=2, vneed=4, w=34, xirc=13, x0=43 +!/ +! +! *** v subscript values *** +! +!/6 +! data dgnorm/1/, dinit/38/, dstnrm/2/, dtinit/39/, d0init/40/, +! 1 f/10/, f0/13/, fdif/11/, gtstep/4/, incfac/23/, lmax0/35/, +! 2 lmaxs/36/, preduc/7/, radfac/16/, radius/8/, rad0/9/, +! 3 reldx/17/, stppar/5/, tuner4/29/, tuner5/30/ +!/7 + integer,parameter :: dgnorm=1, dinit=38, dstnrm=2, dtinit=39, d0init=40,& + f=10, f0=13, fdif=11, gtstep=4, incfac=23, lmax0=35,& + lmaxs=36, preduc=7, radfac=16, radius=8, rad0=9,& + reldx=17, stppar=5, tuner4=29, tuner5=30 +!/ +! +!/6 +! data one/1.d+0/, onep2/1.2d+0/, zero/0.d+0/ +!/7 + real(kind=8),parameter :: one=1.d+0, onep2=1.2d+0, zero=0.d+0 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! + i = iv(1) + if (i .eq. 1) go to 30 + if (i .eq. 2) go to 40 +! +! *** check validity of iv and v input values *** +! + if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) + if (iv(1) .eq. 12 .or. iv(1) .eq. 13) & + iv(vneed) = iv(vneed) + n*(n+21)/2 + 7 + call parck(2, d, iv, liv, lv, n, v) + i = iv(1) - 2 + if (i .gt. 12) go to 999 + nn1o2 = n * (n + 1) / 2 + if (lh .ge. nn1o2) go to (210,210,210,210,210,210,160,120,160,& + 10,10,20), i + iv(1) = 66 + go to 350 +! +! *** storage allocation *** +! + 10 iv(dtol) = iv(lmat) + nn1o2 + iv(x0) = iv(dtol) + 2*n + iv(step) = iv(x0) + n + iv(stlstg) = iv(step) + n + iv(dg) = iv(stlstg) + n + iv(w) = iv(dg) + n + iv(nextv) = iv(w) + 4*n + 7 + if (iv(1) .ne. 13) go to 20 + iv(1) = 14 + go to 999 +! +! *** initialization *** +! + 20 iv(niter) = 0 + iv(nfcall) = 1 + iv(ngcall) = 1 + iv(nfgcal) = 1 + iv(mode) = -1 + iv(model) = 1 + iv(stglim) = 1 + iv(toobig) = 0 + iv(cnvcod) = 0 + iv(radinc) = 0 + v(rad0) = zero + v(stppar) = zero + if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) + k = iv(dtol) + if (v(dtinit) .gt. zero) call vscopy(n, v(k), v(dtinit)) + k = k + n + if (v(d0init) .gt. zero) call vscopy(n, v(k), v(d0init)) + iv(1) = 1 + go to 999 +! + 30 v(f) = fx + if (iv(mode) .ge. 0) go to 210 + iv(1) = 2 + if (iv(toobig) .eq. 0) go to 999 + iv(1) = 63 + go to 350 +! +! *** make sure gradient could be computed *** +! + 40 if (iv(nfgcal) .ne. 0) go to 50 + iv(1) = 65 + go to 350 +! +! *** update the scale vector d *** +! + 50 dg1 = iv(dg) + if (iv(dtype) .le. 0) go to 70 + k = dg1 + j = 0 + do 60 i = 1, n + j = j + i + v(k) = h(j) + k = k + 1 + 60 continue + call dupdu(d, v(dg1), iv, liv, lv, n, v) +! +! *** compute scaled gradient and its norm *** +! + 70 dg1 = iv(dg) + k = dg1 + do 80 i = 1, n + v(k) = g(i) / d(i) + k = k + 1 + 80 continue + v(dgnorm) = v2norm(n, v(dg1)) +! +! *** compute scaled hessian *** +! + k = 1 + do 100 i = 1, n + t = one / d(i) + do 90 j = 1, i + h(k) = t * h(k) / d(j) + k = k + 1 + 90 continue + 100 continue +! + if (iv(cnvcod) .ne. 0) go to 340 + if (iv(mode) .eq. 0) go to 300 +! +! *** allow first step to have scaled 2-norm at most v(lmax0) *** +! + v(radius) = v(lmax0) +! + iv(mode) = 0 +! +! +!----------------------------- main loop ----------------------------- +! +! +! *** print iteration summary, check iteration limit *** +! + 110 call itsum(d, g, iv, liv, lv, n, v, x) + 120 k = iv(niter) + if (k .lt. iv(mxiter)) go to 130 + iv(1) = 10 + go to 350 +! + 130 iv(niter) = k + 1 +! +! *** initialize for start of next iteration *** +! + dg1 = iv(dg) + x01 = iv(x0) + v(f0) = v(f) + iv(irc) = 4 + iv(kagqt) = -1 +! +! *** copy x to x0 *** +! + call vcopy(n, v(x01), x) +! +! *** update radius *** +! + if (k .eq. 0) go to 150 + step1 = iv(step) + k = step1 + do 140 i = 1, n + v(k) = d(i) * v(k) + k = k + 1 + 140 continue + v(radius) = v(radfac) * v2norm(n, v(step1)) +! +! *** check stopx and function evaluation limit *** +! +! AL 4/30/95 + dummy=iv(nfcall) + 150 if (.not. stopx(dummy)) go to 170 + iv(1) = 11 + go to 180 +! +! *** come here when restarting after func. eval. limit or stopx. +! + 160 if (v(f) .ge. v(f0)) go to 170 + v(radfac) = one + k = iv(niter) + go to 130 +! + 170 if (iv(nfcall) .lt. iv(mxfcal)) go to 190 + iv(1) = 9 + 180 if (v(f) .ge. v(f0)) go to 350 +! +! *** in case of stopx or function evaluation limit with +! *** improved v(f), evaluate the gradient at x. +! + iv(cnvcod) = iv(1) + go to 290 +! +!. . . . . . . . . . . . . compute candidate step . . . . . . . . . . +! + 190 step1 = iv(step) + dg1 = iv(dg) + l = iv(lmat) + w1 = iv(w) + call gqtst(d, v(dg1), h, iv(kagqt), v(l), n, v(step1), v, v(w1)) + if (iv(irc) .eq. 6) go to 210 +! +! *** check whether evaluating f(x0 + step) looks worthwhile *** +! + if (v(dstnrm) .le. zero) go to 210 + if (iv(irc) .ne. 5) go to 200 + if (v(radfac) .le. one) go to 200 + if (v(preduc) .le. onep2 * v(fdif)) go to 210 +! +! *** compute f(x0 + step) *** +! + 200 x01 = iv(x0) + step1 = iv(step) + call vaxpy(n, x, one, v(step1), v(x01)) + iv(nfcall) = iv(nfcall) + 1 + iv(1) = 1 + iv(toobig) = 0 + go to 999 +! +!. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . +! + 210 x01 = iv(x0) + v(reldx) = reldst(n, d, x, v(x01)) + call assst(iv, liv, lv, v) + step1 = iv(step) + lstgst = iv(stlstg) + if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) + if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) + if (iv(restor) .ne. 3) go to 220 + call vcopy(n, v(step1), v(lstgst)) + call vaxpy(n, x, one, v(step1), v(x01)) + v(reldx) = reldst(n, d, x, v(x01)) +! + 220 k = iv(irc) + go to (230,260,260,260,230,240,250,250,250,250,250,250,330,300), k +! +! *** recompute step with new radius *** +! + 230 v(radius) = v(radfac) * v(dstnrm) + go to 150 +! +! *** compute step of length v(lmaxs) for singular convergence test. +! + 240 v(radius) = v(lmaxs) + go to 190 +! +! *** convergence or false convergence *** +! + 250 iv(cnvcod) = k - 4 + if (v(f) .ge. v(f0)) go to 340 + if (iv(xirc) .eq. 14) go to 340 + iv(xirc) = 14 +! +!. . . . . . . . . . . . process acceptable step . . . . . . . . . . . +! + 260 if (iv(irc) .ne. 3) go to 290 + temp1 = lstgst +! +! *** prepare for gradient tests *** +! *** set temp1 = hessian * step + g(x0) +! *** = diag(d) * (h * step + g(x0)) +! +! use x0 vector as temporary. + k = x01 + do 270 i = 1, n + v(k) = d(i) * v(step1) + k = k + 1 + step1 = step1 + 1 + 270 continue + call slvmul(n, v(temp1), h, v(x01)) + do 280 i = 1, n + v(temp1) = d(i) * v(temp1) + g(i) + temp1 = temp1 + 1 + 280 continue +! +! *** compute gradient and hessian *** +! + 290 iv(ngcall) = iv(ngcall) + 1 + iv(1) = 2 + go to 999 +! + 300 iv(1) = 2 + if (iv(irc) .ne. 3) go to 110 +! +! *** set v(radfac) by gradient tests *** +! + temp1 = iv(stlstg) + step1 = iv(step) +! +! *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** +! + k = temp1 + do 310 i = 1, n + v(k) = (v(k) - g(i)) / d(i) + k = k + 1 + 310 continue +! +! *** do gradient tests *** +! + if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) go to 320 + if (dotprd(n, g, v(step1)) & + .ge. v(gtstep) * v(tuner5)) go to 110 + 320 v(radfac) = v(incfac) + go to 110 +! +!. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . +! +! *** bad parameters to assess *** +! + 330 iv(1) = 64 + go to 350 +! +! *** print summary of final iteration and other requested items *** +! + 340 iv(1) = iv(cnvcod) + iv(cnvcod) = 0 + 350 call itsum(d, g, iv, liv, lv, n, v, x) +! + 999 return +! +! *** last card of humit follows *** + end subroutine humit +!----------------------------------------------------------------------------- + subroutine dupdu(d, hdiag, iv, liv, lv, n, v) +! +! *** update scale vector d for humsl *** +! +! *** parameter declarations *** +! + integer :: liv, lv, n + integer :: iv(liv) + real(kind=8) :: d(n), hdiag(n), v(lv) +! +! *** local variables *** +! + integer :: dtoli, d0i, i + real(kind=8) :: t, vdfac +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dabs, dmax1, dsqrt +!/ +! *** subscripts for iv and v *** +! +!el integer :: dfac, dtol, dtype, niter +!/6 +! data dfac/41/, dtol/59/, dtype/16/, niter/31/ +!/7 + integer,parameter :: dfac=41, dtol=59, dtype=16, niter=31 +!/ +! +!------------------------------- body -------------------------------- +! + i = iv(dtype) + if (i .eq. 1) go to 10 + if (iv(niter) .gt. 0) go to 999 +! + 10 dtoli = iv(dtol) + d0i = dtoli + n + vdfac = v(dfac) + do 20 i = 1, n + t = dmax1(dsqrt(dabs(hdiag(i))), vdfac*d(i)) + if (t .lt. v(dtoli)) t = dmax1(v(dtoli), v(d0i)) + d(i) = t + dtoli = dtoli + 1 + d0i = d0i + 1 + 20 continue +! + 999 return +! *** last card of dupdu follows *** + end subroutine dupdu +!----------------------------------------------------------------------------- + subroutine gqtst(d, dig, dihdi, ka, l, p, step, v, w) +! +! *** compute goldfeld-quandt-trotter step by more-hebden technique *** +! *** (nl2sol version 2.2), modified a la more and sorensen *** +! +! *** parameter declarations *** +! + integer :: ka, p +!al real(kind=8) :: d(p), dig(p), dihdi(1), l(1), v(21), step(p), +!al 1 w(1) + real(kind=8) :: d(p), dig(p), dihdi(p*(p+1)/2), l(p*(p+1)/2),& + v(21), step(p),w(4*p+7) +! dimension dihdi(p*(p+1)/2), l(p*(p+1)/2), w(4*p+7) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! *** purpose *** +! +! given the (compactly stored) lower triangle of a scaled +! hessian (approximation) and a nonzero scaled gradient vector, +! this subroutine computes a goldfeld-quandt-trotter step of +! approximate length v(radius) by the more-hebden technique. in +! other words, step is computed to (approximately) minimize +! psi(step) = (g**t)*step + 0.5*(step**t)*h*step such that the +! 2-norm of d*step is at most (approximately) v(radius), where +! g is the gradient, h is the hessian, and d is a diagonal +! scale matrix whose diagonal is stored in the parameter d. +! (gqtst assumes dig = d**-1 * g and dihdi = d**-1 * h * d**-1.) +! +! *** parameter description *** +! +! d (in) = the scale vector, i.e. the diagonal of the scale +! matrix d mentioned above under purpose. +! dig (in) = the scaled gradient vector, d**-1 * g. if g = 0, then +! step = 0 and v(stppar) = 0 are returned. +! dihdi (in) = lower triangle of the scaled hessian (approximation), +! i.e., d**-1 * h * d**-1, stored compactly by rows., i.e., +! in the order (1,1), (2,1), (2,2), (3,1), (3,2), etc. +! ka (i/o) = the number of hebden iterations (so far) taken to deter- +! mine step. ka .lt. 0 on input means this is the first +! attempt to determine step (for the present dig and dihdi) +! -- ka is initialized to 0 in this case. output with +! ka = 0 (or v(stppar) = 0) means step = -(h**-1)*g. +! l (i/o) = workspace of length p*(p+1)/2 for cholesky factors. +! p (in) = number of parameters -- the hessian is a p x p matrix. +! step (i/o) = the step computed. +! v (i/o) contains various constants and variables described below. +! w (i/o) = workspace of length 4*p + 6. +! +! *** entries in v *** +! +! v(dgnorm) (i/o) = 2-norm of (d**-1)*g. +! v(dstnrm) (output) = 2-norm of d*step. +! v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or +! overestimate of smallest eigenvalue of (d**-1)*h*(d**-1). +! v(epslon) (in) = max. rel. error allowed for psi(step). for the +! step returned, psi(step) will exceed its optimal value +! by less than -v(epslon)*psi(step). suggested value = 0.1. +! v(gtstep) (out) = inner product between g and step. +! v(nreduc) (out) = psi(-(h**-1)*g) = psi(newton step) (for pos. def. +! h only -- v(nreduc) is set to zero otherwise). +! v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step +! (more*s sigma). the error v(dstnrm) - v(radius) must lie +! between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). +! v(phmxfc) (in) (see v(phmnfc).) +! suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5. +! v(preduc) (out) = psi(step) = predicted obj. func. reduction for step. +! v(radius) (in) = radius of current (scaled) trust region. +! v(rad0) (i/o) = value of v(radius) from previous call. +! v(stppar) (i/o) is normally the marquardt parameter, i.e. the alpha +! described below under algorithm notes. if h + alpha*d**2 +! (see algorithm notes) is (nearly) singular, however, +! then v(stppar) = -alpha. +! +! *** usage notes *** +! +! if it is desired to recompute step using a different value of +! v(radius), then this routine may be restarted by calling it +! with all parameters unchanged except v(radius). (this explains +! why step and w are listed as i/o). on an initial call (one with +! ka .lt. 0), step and w need not be initialized and only compo- +! nents v(epslon), v(stppar), v(phmnfc), v(phmxfc), v(radius), and +! v(rad0) of v must be initialized. +! +! *** algorithm notes *** +! +! the desired g-q-t step (ref. 2, 3, 4, 6) satisfies +! (h + alpha*d**2)*step = -g for some nonnegative alpha such that +! h + alpha*d**2 is positive semidefinite. alpha and step are +! computed by a scheme analogous to the one described in ref. 5. +! estimates of the smallest and largest eigenvalues of the hessian +! are obtained from the gerschgorin circle theorem enhanced by a +! simple form of the scaling described in ref. 7. cases in which +! h + alpha*d**2 is nearly (or exactly) singular are handled by +! the technique discussed in ref. 2. in these cases, a step of +! (exact) length v(radius) is returned for which psi(step) exceeds +! its optimal value by less than -v(epslon)*psi(step). the test +! suggested in ref. 6 for detecting the special case is performed +! once two matrix factorizations have been done -- doing so sooner +! seems to degrade the performance of optimization routines that +! call this routine. +! +! *** functions and subroutines called *** +! +! dotprd - returns inner product of two vectors. +! litvmu - applies inverse-transpose of compact lower triang. matrix. +! livmul - applies inverse of compact lower triang. matrix. +! lsqrt - finds cholesky factor (of compactly stored lower triang.). +! lsvmin - returns approx. to min. sing. value of lower triang. matrix. +! rmdcon - returns machine-dependent constants. +! v2norm - returns 2-norm of a vector. +! +! *** references *** +! +! 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), an adaptive +! nonlinear least-squares algorithm, acm trans. math. +! software, vol. 7, no. 3. +! 2. gay, d.m. (1981), computing optimal locally constrained steps, +! siam j. sci. statist. computing, vol. 2, no. 2, pp. +! 186-197. +! 3. goldfeld, s.m., quandt, r.e., and trotter, h.f. (1966), +! maximization by quadratic hill-climbing, econometrica 34, +! pp. 541-551. +! 4. hebden, m.d. (1973), an algorithm for minimization using exact +! second derivatives, report t.p. 515, theoretical physics +! div., a.e.r.e. harwell, oxon., england. +! 5. more, j.j. (1978), the levenberg-marquardt algorithm, implemen- +! tation and theory, pp.105-116 of springer lecture notes +! in mathematics no. 630, edited by g.a. watson, springer- +! verlag, berlin and new york. +! 6. more, j.j., and sorensen, d.c. (1981), computing a trust region +! step, technical report anl-81-83, argonne national lab. +! 7. varga, r.s. (1965), minimal gerschgorin sets, pacific j. math. 15, +! pp. 719-729. +! +! *** general *** +! +! coded by david m. gay. +! this subroutine was written in connection with research +! supported by the national science foundation under grants +! mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and +! mcs-7906671. +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! *** local variables *** +! + logical :: restrt + integer :: dggdmx, diag, diag0, dstsav, emax, emin, i, im1, inc, irc,& + j, k, kalim, kamin, k1, lk0, phipin, q, q0, uk0, x + real(kind=8) :: alphak, aki, akk, delta, dst, eps, gtsta, lk,& + oldphi, phi, phimax, phimin, psifac, rad, radsq,& + root, si, sk, sw, t, twopsi, t1, t2, uk, wi +! +! *** constants *** + real(kind=8) :: big, dgxfac !el, epsfac, four, half, kappa, negone, +!el 1 one, p001, six, three, two, zero +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dabs, dmax1, dmin1, dsqrt +!/ +! *** external functions and subroutines *** +! +!el external dotprd, litvmu, livmul, lsqrt, lsvmin, rmdcon, v2norm +!el real(kind=8) :: dotprd, lsvmin, rmdcon, v2norm +! +! *** subscripts for v *** +! +!el integer dgnorm, dstnrm, dst0, epslon, gtstep, stppar, nreduc, +!el 1 phmnfc, phmxfc, preduc, radius, rad0 +!/6 +! data dgnorm/1/, dstnrm/2/, dst0/3/, epslon/19/, gtstep/4/, +! 1 nreduc/6/, phmnfc/20/, phmxfc/21/, preduc/7/, radius/8/, +! 2 rad0/9/, stppar/5/ +!/7 + integer,parameter :: dgnorm=1, dstnrm=2, dst0=3, epslon=19, gtstep=4,& + nreduc=6, phmnfc=20, phmxfc=21, preduc=7, radius=8,& + rad0=9, stppar=5 +!/ +! +!/6 +! data epsfac/50.0d+0/, four/4.0d+0/, half/0.5d+0/, +! 1 kappa/2.0d+0/, negone/-1.0d+0/, one/1.0d+0/, p001/1.0d-3/, +! 2 six/6.0d+0/, three/3.0d+0/, two/2.0d+0/, zero/0.0d+0/ +!/7 + real(kind=8), parameter :: epsfac=50.0d+0, four=4.0d+0, half=0.5d+0,& + kappa=2.0d+0, negone=-1.0d+0, one=1.0d+0, p001=1.0d-3,& + six=6.0d+0, three=3.0d+0, two=2.0d+0, zero=0.0d+0 + save dgxfac +!/ + data big/0.d+0/, dgxfac/0.d+0/ +! +! *** body *** +! +! *** store largest abs. entry in (d**-1)*h*(d**-1) at w(dggdmx). + dggdmx = p + 1 +! *** store gerschgorin over- and underestimates of the largest +! *** and smallest eigenvalues of (d**-1)*h*(d**-1) at w(emax) +! *** and w(emin) respectively. + emax = dggdmx + 1 + emin = emax + 1 +! *** for use in recomputing step, the final values of lk, uk, dst, +! *** and the inverse derivative of more*s phi at 0 (for pos. def. +! *** h) are stored in w(lk0), w(uk0), w(dstsav), and w(phipin) +! *** respectively. + lk0 = emin + 1 + phipin = lk0 + 1 + uk0 = phipin + 1 + dstsav = uk0 + 1 +! *** store diag of (d**-1)*h*(d**-1) in w(diag),...,w(diag0+p). + diag0 = dstsav + diag = diag0 + 1 +! *** store -d*step in w(q),...,w(q0+p). + q0 = diag0 + p + q = q0 + 1 +! *** allocate storage for scratch vector x *** + x = q + p + rad = v(radius) + radsq = rad**2 +! *** phitol = max. error allowed in dst = v(dstnrm) = 2-norm of +! *** d*step. + phimax = v(phmxfc) * rad + phimin = v(phmnfc) * rad + psifac = two * v(epslon) / (three * (four * (v(phmnfc) + one) * & + (kappa + one) + kappa + two) * rad**2) +! *** oldphi is used to detect limits of numerical accuracy. if +! *** we recompute step and it does not change, then we accept it. + oldphi = zero + eps = v(epslon) + irc = 0 + restrt = .false. + kalim = ka + 50 +! +! *** start or restart, depending on ka *** +! + if (ka .ge. 0) go to 290 +! +! *** fresh start *** +! + k = 0 + uk = negone + ka = 0 + kalim = 50 + v(dgnorm) = v2norm(p, dig) + v(nreduc) = zero + v(dst0) = zero + kamin = 3 + if (v(dgnorm) .eq. zero) kamin = 0 +! +! *** store diag(dihdi) in w(diag0+1),...,w(diag0+p) *** +! + j = 0 + do 10 i = 1, p + j = j + i + k1 = diag0 + i + w(k1) = dihdi(j) + 10 continue +! +! *** determine w(dggdmx), the largest element of dihdi *** +! + t1 = zero + j = p * (p + 1) / 2 + do 20 i = 1, j + t = dabs(dihdi(i)) + if (t1 .lt. t) t1 = t + 20 continue + w(dggdmx) = t1 +! +! *** try alpha = 0 *** +! + 30 call lsqrt(1, p, l, dihdi, irc) + if (irc .eq. 0) go to 50 +! *** indef. h -- underestimate smallest eigenvalue, use this +! *** estimate to initialize lower bound lk on alpha. + j = irc*(irc+1)/2 + t = l(j) + l(j) = one + do 40 i = 1, irc + 40 w(i) = zero + w(irc) = one + call litvmu(irc, w, l, w) + t1 = v2norm(irc, w) + lk = -t / t1 / t1 + v(dst0) = -lk + if (restrt) go to 210 + go to 70 +! +! *** positive definite h -- compute unmodified newton step. *** + 50 lk = zero + t = lsvmin(p, l, w(q), w(q)) + if (t .ge. one) go to 60 + if (big .le. zero) big = rmdcon(6) + if (v(dgnorm) .ge. t*t*big) go to 70 + 60 call livmul(p, w(q), l, dig) + gtsta = dotprd(p, w(q), w(q)) + v(nreduc) = half * gtsta + call litvmu(p, w(q), l, w(q)) + dst = v2norm(p, w(q)) + v(dst0) = dst + phi = dst - rad + if (phi .le. phimax) go to 260 + if (restrt) go to 210 +! +! *** prepare to compute gerschgorin estimates of largest (and +! *** smallest) eigenvalues. *** +! + 70 k = 0 + do 100 i = 1, p + wi = zero + if (i .eq. 1) go to 90 + im1 = i - 1 + do 80 j = 1, im1 + k = k + 1 + t = dabs(dihdi(k)) + wi = wi + t + w(j) = w(j) + t + 80 continue + 90 w(i) = wi + k = k + 1 + 100 continue +! +! *** (under-)estimate smallest eigenvalue of (d**-1)*h*(d**-1) *** +! + k = 1 + t1 = w(diag) - w(1) + if (p .le. 1) go to 120 + do 110 i = 2, p + j = diag0 + i + t = w(j) - w(i) + if (t .ge. t1) go to 110 + t1 = t + k = i + 110 continue +! + 120 sk = w(k) + j = diag0 + k + akk = w(j) + k1 = k*(k-1)/2 + 1 + inc = 1 + t = zero + do 150 i = 1, p + if (i .eq. k) go to 130 + aki = dabs(dihdi(k1)) + si = w(i) + j = diag0 + i + t1 = half * (akk - w(j) + si - aki) + t1 = t1 + dsqrt(t1*t1 + sk*aki) + if (t .lt. t1) t = t1 + if (i .lt. k) go to 140 + 130 inc = i + 140 k1 = k1 + inc + 150 continue +! + w(emin) = akk - t + uk = v(dgnorm)/rad - w(emin) + if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk + if (uk .le. zero) uk = p001 +! +! *** compute gerschgorin (over-)estimate of largest eigenvalue *** +! + k = 1 + t1 = w(diag) + w(1) + if (p .le. 1) go to 170 + do 160 i = 2, p + j = diag0 + i + t = w(j) + w(i) + if (t .le. t1) go to 160 + t1 = t + k = i + 160 continue +! + 170 sk = w(k) + j = diag0 + k + akk = w(j) + k1 = k*(k-1)/2 + 1 + inc = 1 + t = zero + do 200 i = 1, p + if (i .eq. k) go to 180 + aki = dabs(dihdi(k1)) + si = w(i) + j = diag0 + i + t1 = half * (w(j) + si - aki - akk) + t1 = t1 + dsqrt(t1*t1 + sk*aki) + if (t .lt. t1) t = t1 + if (i .lt. k) go to 190 + 180 inc = i + 190 k1 = k1 + inc + 200 continue +! + w(emax) = akk + t + lk = dmax1(lk, v(dgnorm)/rad - w(emax)) +! +! *** alphak = current value of alpha (see alg. notes above). we +! *** use more*s scheme for initializing it. + alphak = dabs(v(stppar)) * v(rad0)/rad +! + if (irc .ne. 0) go to 210 +! +! *** compute l0 for positive definite h *** +! + call livmul(p, w, l, w(q)) + t = v2norm(p, w) + w(phipin) = dst / t / t + lk = dmax1(lk, phi*w(phipin)) +! +! *** safeguard alphak and add alphak*i to (d**-1)*h*(d**-1) *** +! + 210 ka = ka + 1 + if (-v(dst0) .ge. alphak .or. alphak .lt. lk .or. alphak .ge. uk) & + alphak = uk * dmax1(p001, dsqrt(lk/uk)) + if (alphak .le. zero) alphak = half * uk + if (alphak .le. zero) alphak = uk + k = 0 + do 220 i = 1, p + k = k + i + j = diag0 + i + dihdi(k) = w(j) + alphak + 220 continue +! +! *** try computing cholesky decomposition *** +! + call lsqrt(1, p, l, dihdi, irc) + if (irc .eq. 0) go to 240 +! +! *** (d**-1)*h*(d**-1) + alphak*i is indefinite -- overestimate +! *** smallest eigenvalue for use in updating lk *** +! + j = (irc*(irc+1))/2 + t = l(j) + l(j) = one + do 230 i = 1, irc + 230 w(i) = zero + w(irc) = one + call litvmu(irc, w, l, w) + t1 = v2norm(irc, w) + lk = alphak - t/t1/t1 + v(dst0) = -lk + go to 210 +! +! *** alphak makes (d**-1)*h*(d**-1) positive definite. +! *** compute q = -d*step, check for convergence. *** +! + 240 call livmul(p, w(q), l, dig) + gtsta = dotprd(p, w(q), w(q)) + call litvmu(p, w(q), l, w(q)) + dst = v2norm(p, w(q)) + phi = dst - rad + if (phi .le. phimax .and. phi .ge. phimin) go to 270 + if (phi .eq. oldphi) go to 270 + oldphi = phi + if (phi .lt. zero) go to 330 +! +! *** unacceptable alphak -- update lk, uk, alphak *** +! + 250 if (ka .ge. kalim) go to 270 +! *** the following dmin1 is necessary because of restarts *** + if (phi .lt. zero) uk = dmin1(uk, alphak) +! *** kamin = 0 only iff the gradient vanishes *** + if (kamin .eq. 0) go to 210 + call livmul(p, w, l, w(q)) + t1 = v2norm(p, w) + alphak = alphak + (phi/t1) * (dst/t1) * (dst/rad) + lk = dmax1(lk, alphak) + go to 210 +! +! *** acceptable step on first try *** +! + 260 alphak = zero +! +! *** successful step in general. compute step = -(d**-1)*q *** +! + 270 do 280 i = 1, p + j = q0 + i + step(i) = -w(j)/d(i) + 280 continue + v(gtstep) = -gtsta + v(preduc) = half * (dabs(alphak)*dst*dst + gtsta) + go to 410 +! +! +! *** restart with new radius *** +! + 290 if (v(dst0) .le. zero .or. v(dst0) - rad .gt. phimax) go to 310 +! +! *** prepare to return newton step *** +! + restrt = .true. + ka = ka + 1 + k = 0 + do 300 i = 1, p + k = k + i + j = diag0 + i + dihdi(k) = w(j) + 300 continue + uk = negone + go to 30 +! + 310 kamin = ka + 3 + if (v(dgnorm) .eq. zero) kamin = 0 + if (ka .eq. 0) go to 50 +! + dst = w(dstsav) + alphak = dabs(v(stppar)) + phi = dst - rad + t = v(dgnorm)/rad + uk = t - w(emin) + if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk + if (uk .le. zero) uk = p001 + if (rad .gt. v(rad0)) go to 320 +! +! *** smaller radius *** + lk = zero + if (alphak .gt. zero) lk = w(lk0) + lk = dmax1(lk, t - w(emax)) + if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) + go to 250 +! +! *** bigger radius *** + 320 if (alphak .gt. zero) uk = dmin1(uk, w(uk0)) + lk = dmax1(zero, -v(dst0), t - w(emax)) + if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) + go to 250 +! +! *** decide whether to check for special case... in practice (from +! *** the standpoint of the calling optimization code) it seems best +! *** not to check until a few iterations have failed -- hence the +! *** test on kamin below. +! + 330 delta = alphak + dmin1(zero, v(dst0)) + twopsi = alphak*dst*dst + gtsta + if (ka .ge. kamin) go to 340 +! *** if the test in ref. 2 is satisfied, fall through to handle +! *** the special case (as soon as the more-sorensen test detects +! *** it). + if (delta .ge. psifac*twopsi) go to 370 +! +! *** check for the special case of h + alpha*d**2 (nearly) +! *** singular. use one step of inverse power method with start +! *** from lsvmin to obtain approximate eigenvector corresponding +! *** to smallest eigenvalue of (d**-1)*h*(d**-1). lsvmin returns +! *** x and w with l*w = x. +! + 340 t = lsvmin(p, l, w(x), w) +! +! *** normalize w *** + do 350 i = 1, p + 350 w(i) = t*w(i) +! *** complete current inv. power iter. -- replace w by (l**-t)*w. + call litvmu(p, w, l, w) + t2 = one/v2norm(p, w) + do 360 i = 1, p + 360 w(i) = t2*w(i) + t = t2 * t +! +! *** now w is the desired approximate (unit) eigenvector and +! *** t*x = ((d**-1)*h*(d**-1) + alphak*i)*w. +! + sw = dotprd(p, w(q), w) + t1 = (rad + dst) * (rad - dst) + root = dsqrt(sw*sw + t1) + if (sw .lt. zero) root = -root + si = t1 / (sw + root) +! +! *** the actual test for the special case... +! + if ((t2*si)**2 .le. eps*(dst**2 + alphak*radsq)) go to 380 +! +! *** update upper bound on smallest eigenvalue (when not positive) +! *** (as recommended by more and sorensen) and continue... +! + if (v(dst0) .le. zero) v(dst0) = dmin1(v(dst0), t2**2 - alphak) + lk = dmax1(lk, -v(dst0)) +! +! *** check whether we can hope to detect the special case in +! *** the available arithmetic. accept step as it is if not. +! +! *** if not yet available, obtain machine dependent value dgxfac. + 370 if (dgxfac .eq. zero) dgxfac = epsfac * rmdcon(3) +! + if (delta .gt. dgxfac*w(dggdmx)) go to 250 + go to 270 +! +! *** special case detected... negate alphak to indicate special case +! + 380 alphak = -alphak + v(preduc) = half * twopsi +! +! *** accept current step if adding si*w would lead to a +! *** further relative reduction in psi of less than v(epslon)/3. +! + t1 = zero + t = si*(alphak*sw - half*si*(alphak + t*dotprd(p,w(x),w))) + if (t .lt. eps*twopsi/six) go to 390 + v(preduc) = v(preduc) + t + dst = rad + t1 = -si + 390 do 400 i = 1, p + j = q0 + i + w(j) = t1*w(i) - w(j) + step(i) = w(j) / d(i) + 400 continue + v(gtstep) = dotprd(p, dig, w(q)) +! +! *** save values for use in a possible restart *** +! + 410 v(dstnrm) = dst + v(stppar) = alphak + w(lk0) = lk + w(uk0) = uk + v(rad0) = rad + w(dstsav) = dst +! +! *** restore diagonal of dihdi *** +! + j = 0 + do 420 i = 1, p + j = j + i + k = diag0 + i + dihdi(j) = w(k) + 420 continue +! + 999 return +! +! *** last card of gqtst follows *** + end subroutine gqtst +!----------------------------------------------------------------------------- + subroutine lsqrt(n1, n, l, a, irc) +! +! *** compute rows n1 through n of the cholesky factor l of +! *** a = l*(l**t), where l and the lower triangle of a are both +! *** stored compactly by rows (and may occupy the same storage). +! *** irc = 0 means all went well. irc = j means the leading +! *** principal j x j submatrix of a is not positive definite -- +! *** and l(j*(j+1)/2) contains the (nonpos.) reduced j-th diagonal. +! +! *** parameters *** +! + integer :: n1, n, irc +!al real(kind=8) :: l(1), a(1) + real(kind=8) :: l(n*(n+1)/2), a(n*(n+1)/2) +! dimension l(n*(n+1)/2), a(n*(n+1)/2) +! +! *** local variables *** +! + integer :: i, ij, ik, im1, i0, j, jk, jm1, j0, k + real(kind=8) :: t, td !el, zero +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dsqrt +!/ +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +! +! *** body *** +! + i0 = n1 * (n1 - 1) / 2 + do 50 i = n1, n + td = zero + if (i .eq. 1) go to 40 + j0 = 0 + im1 = i - 1 + do 30 j = 1, im1 + t = zero + if (j .eq. 1) go to 20 + jm1 = j - 1 + do 10 k = 1, jm1 + ik = i0 + k + jk = j0 + k + t = t + l(ik)*l(jk) + 10 continue + 20 ij = i0 + j + j0 = j0 + j + t = (a(ij) - t) / l(j0) + l(ij) = t + td = td + t*t + 30 continue + 40 i0 = i0 + i + t = a(i0) - td + if (t .le. zero) go to 60 + l(i0) = dsqrt(t) + 50 continue +! + irc = 0 + go to 999 +! + 60 l(i0) = t + irc = i +! + 999 return +! +! *** last card of lsqrt *** + end subroutine lsqrt +!----------------------------------------------------------------------------- + real(kind=8) function lsvmin(p, l, x, y) +! +! *** estimate smallest sing. value of packed lower triang. matrix l +! +! *** parameter declarations *** +! + integer :: p +!al real(kind=8) :: l(1), x(p), y(p) + real(kind=8) :: l(p*(p+1)/2), x(p), y(p) +! dimension l(p*(p+1)/2) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! *** purpose *** +! +! this function returns a good over-estimate of the smallest +! singular value of the packed lower triangular matrix l. +! +! *** parameter description *** +! +! p (in) = the order of l. l is a p x p lower triangular matrix. +! l (in) = array holding the elements of l in row order, i.e. +! l(1,1), l(2,1), l(2,2), l(3,1), l(3,2), l(3,3), etc. +! x (out) if lsvmin returns a positive value, then x is a normalized +! approximate left singular vector corresponding to the +! smallest singular value. this approximation may be very +! crude. if lsvmin returns zero, then some components of x +! are zero and the rest retain their input values. +! y (out) if lsvmin returns a positive value, then y = (l**-1)*x is an +! unnormalized approximate right singular vector correspond- +! ing to the smallest singular value. this approximation +! may be crude. if lsvmin returns zero, then y retains its +! input value. the caller may pass the same vector for x +! and y (nonstandard fortran usage), in which case y over- +! writes x (for nonzero lsvmin returns). +! +! *** algorithm notes *** +! +! the algorithm is based on (1), with the additional provision that +! lsvmin = 0 is returned if the smallest diagonal element of l +! (in magnitude) is not more than the unit roundoff times the +! largest. the algorithm uses a random number generator proposed +! in (4), which passes the spectral test with flying colors -- see +! (2) and (3). +! +! *** subroutines and functions called *** +! +! v2norm - function, returns the 2-norm of a vector. +! +! *** references *** +! +! (1) cline, a., moler, c., stewart, g., and wilkinson, j.h.(1977), +! an estimate for the condition number of a matrix, report +! tm-310, applied math. div., argonne national laboratory. +! +! (2) hoaglin, d.c. (1976), theoretical properties of congruential +! random-number generators -- an empirical view, +! memorandum ns-340, dept. of statistics, harvard univ. +! +! (3) knuth, d.e. (1969), the art of computer programming, vol. 2 +! (seminumerical algorithms), addison-wesley, reading, mass. +! +! (4) smith, c.s. (1971), multiplicative pseudo-random number +! generators with prime modulus, j. assoc. comput. mach. 18, +! pp. 586-593. +! +! *** history *** +! +! designed and coded by david m. gay (winter 1977/summer 1978). +! +! *** general *** +! +! this subroutine was written in connection with research +! supported by the national science foundation under grants +! mcs-7600324, dcr75-10143, 76-14311dss, and mcs76-11989. +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! *** local variables *** +! + integer :: i, ii, ix, j, ji, jj, jjj, jm1, j0, pm1 + real(kind=8) :: b, sminus, splus, t, xminus, xplus +! +! *** constants *** +! +!el real(kind=8) :: half, one, r9973, zero +! +! *** intrinsic functions *** +!/+ +!el integer mod +!el real float +!el real(kind=8) :: dabs +!/ +! *** external functions and subroutines *** +! +!el external dotprd, v2norm, vaxpy +!el real(kind=8) :: dotprd, v2norm +! +!/6 +! data half/0.5d+0/, one/1.d+0/, r9973/9973.d+0/, zero/0.d+0/ +!/7 + real(kind=8),parameter :: half=0.5d+0, one=1.d+0, r9973=9973.d+0, zero=0.d+0 +!/ +! +! *** body *** +! + ix = 2 + pm1 = p - 1 +! +! *** first check whether to return lsvmin = 0 and initialize x *** +! + ii = 0 + j0 = p*pm1/2 + jj = j0 + p + if (l(jj) .eq. zero) go to 110 + ix = mod(3432*ix, 9973) + b = half*(one + float(ix)/r9973) + xplus = b / l(jj) + x(p) = xplus + if (p .le. 1) go to 60 + do 10 i = 1, pm1 + ii = ii + i + if (l(ii) .eq. zero) go to 110 + ji = j0 + i + x(i) = xplus * l(ji) + 10 continue +! +! *** solve (l**t)*x = b, where the components of b have randomly +! *** chosen magnitudes in (.5,1) with signs chosen to make x large. +! +! do j = p-1 to 1 by -1... + do 50 jjj = 1, pm1 + j = p - jjj +! *** determine x(j) in this iteration. note for i = 1,2,...,j +! *** that x(i) holds the current partial sum for row i. + ix = mod(3432*ix, 9973) + b = half*(one + float(ix)/r9973) + xplus = (b - x(j)) + xminus = (-b - x(j)) + splus = dabs(xplus) + sminus = dabs(xminus) + jm1 = j - 1 + j0 = j*jm1/2 + jj = j0 + j + xplus = xplus/l(jj) + xminus = xminus/l(jj) + if (jm1 .eq. 0) go to 30 + do 20 i = 1, jm1 + ji = j0 + i + splus = splus + dabs(x(i) + l(ji)*xplus) + sminus = sminus + dabs(x(i) + l(ji)*xminus) + 20 continue + 30 if (sminus .gt. splus) xplus = xminus + x(j) = xplus +! *** update partial sums *** + if (jm1 .gt. 0) call vaxpy(jm1, x, xplus, l(j0+1), x) + 50 continue +! +! *** normalize x *** +! + 60 t = one/v2norm(p, x) + do 70 i = 1, p + 70 x(i) = t*x(i) +! +! *** solve l*y = x and return lsvmin = 1/twonorm(y) *** +! + do 100 j = 1, p + jm1 = j - 1 + j0 = j*jm1/2 + jj = j0 + j + t = zero + if (jm1 .gt. 0) t = dotprd(jm1, l(j0+1), y) + y(j) = (x(j) - t) / l(jj) + 100 continue +! + lsvmin = one/v2norm(p, y) + go to 999 +! + 110 lsvmin = zero + 999 return +! *** last card of lsvmin follows *** + end function lsvmin +!----------------------------------------------------------------------------- + subroutine slvmul(p, y, s, x) +! +! *** set y = s * x, s = p x p symmetric matrix. *** +! *** lower triangle of s stored rowwise. *** +! +! *** parameter declarations *** +! + integer :: p +!al real(kind=8) :: s(1), x(p), y(p) + real(kind=8) :: s(p*(p+1)/2), x(p), y(p) +! dimension s(p*(p+1)/2) +! +! *** local variables *** +! + integer :: i, im1, j, k + real(kind=8) :: xi +! +! *** no intrinsic functions *** +! +! *** external function *** +! +!el external dotprd +!el real(kind=8) :: dotprd +! +!----------------------------------------------------------------------- +! + j = 1 + do 10 i = 1, p + y(i) = dotprd(i, s(j), x) + j = j + i + 10 continue +! + if (p .le. 1) go to 999 + j = 1 + do 40 i = 2, p + xi = x(i) + im1 = i - 1 + j = j + 1 + do 30 k = 1, im1 + y(k) = y(k) + s(j)*xi + j = j + 1 + 30 continue + 40 continue +! + 999 return +! *** last card of slvmul follows *** + end subroutine slvmul +!----------------------------------------------------------------------------- +! minimize_p.F +!----------------------------------------------------------------------------- + subroutine minimize(etot,x,iretcode,nfun) + + use energy, only: func,gradient,fdum!,etotal,enerprint + use comm_srutu +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer,parameter :: liv=60 +! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) +!******************************************************************** +! OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * +! the calling subprogram. * +! when d(i)=1.0, then v(35) is the length of the initial step, * +! calculated in the usual pythagorean way. * +! absolute convergence occurs when the function is within v(31) of * +! zero. unless you know the minimum value in advance, abs convg * +! is probably not useful. * +! relative convergence is when the model predicts that the function * +! will decrease by less than v(32)*abs(fun). * +!******************************************************************** +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.MINIM' + integer :: i +!el common /srutu/ icall + integer,dimension(liv) :: iv + real(kind=8) :: minval !,v(1:77+(6*nres)*(6*nres+17)/2) !(1:lv) +!el real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) + real(kind=8) :: energia(0:n_ene) +! external func,gradient,fdum +! external func_restr,grad_restr + logical :: not_done,change,reduce +!el common /przechowalnia/ v +!el local variables + integer :: iretcode,nfun,lv,nvar_restr,idum(1),j + real(kind=8) :: etot,rdum(1) !,fdum + + lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) + + if (.not.allocated(v)) allocate(v(1:lv)) + + icall = 1 + + NOT_DONE=.TRUE. + +! DO WHILE (NOT_DONE) + + call deflt(2,iv,liv,lv,v) +! 12 means fresh start, dont call deflt + iv(1)=12 +! max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +! max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +! controls output + iv(19)=2 +! selects output unit + iv(21)=0 + if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout +! 1 means to print out result + iv(22)=print_min_res +! 1 means to print out summary stats + iv(23)=print_min_stat +! 1 means to print initial x and d + iv(24)=print_min_ini +! min val for v(radfac) default is 0.1 + v(24)=0.1D0 +! max val for v(radfac) default is 4.0 + v(25)=2.0D0 +! v(25)=4.0D0 +! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +! the sumsl default is 0.1 + v(26)=0.1D0 +! false conv if (act fnctn decrease) .lt. v(34) +! the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +! absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +! relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +! controls initial step size + v(35)=1.0D-1 +! large vals of d correspond to small components of step + do i=1,nphi + d(i)=1.0D-1 + enddo + do i=nphi+1,nvar + d(i)=1.0D-1 + enddo +!d print *,'Calling SUMSL' +! call var_to_geom(nvar,x) +! call chainbuild +! call etotal(energia(0)) +! etot = energia(0) +!elmask_r=.true. + IF (mask_r) THEN + call x2xx(x,xx,nvar_restr) + call sumsl(nvar_restr,d,xx,func_restr,grad_restr,& + iv,liv,lv,v,idum,rdum,fdum) + call xx2x(x,xx) + ELSE + call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) + ENDIF + etot=v(10) + iretcode=iv(1) +!d print *,'Exit SUMSL; return code:',iretcode,' energy:',etot +!d write (iout,'(/a,i4/)') 'SUMSL return code:',iv(1) +! call intout +! change=reduce(x) + call var_to_geom(nvar,x) +! if (change) then +! write (iout,'(a)') 'Reduction worked, minimizing again...' +! else +! not_done=.false. +! endif + call chainbuild + +!el--------------------- +! write (iout,'(/a)') & +! "Cartesian coordinates of the reference structure after SUMSL" +! write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & +! "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" +! do i=1,nres +! write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & +! restyp(itype(i)),i,(c(j,i),j=1,3),& +! (c(j,i+nres),j=1,3) +! enddo +!el---------------------------- +! call etotal(energia) !sp +! etot=energia(0) +! call enerprint(energia) !sp + nfun=iv(6) + +! write (*,*) 'Processor',MyID,' leaves MINIMIZE.' + +! ENDDO ! NOT_DONE + + return + end subroutine minimize +!----------------------------------------------------------------------------- +! gradient_p.F +!----------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + + use energy, only: cartder,zerograd,etotal,sum_gradient +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +!EL external ufparm + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) + integer :: n,nf,ig,ind,i,j,ij,k,igall + real(kind=8) :: f,gphii,gthetai,galphai,gomegai + real(kind=8),external :: ufparm + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +! write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +! Intercept NaNs in the coordinates +! write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +! +! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +! + 40 call cartder +! +! Convert the Cartesian gradient into internal-coordinate gradient. +! + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +! +! Add the components corresponding to local energy terms. +! + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +!d do i=1,ig +!d write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +!d enddo + return + end subroutine grad_restr +!----------------------------------------------------------------------------- + subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F + + use comm_chu + use energy, only: zerograd,etotal,sum_gradient +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' + integer :: n,nf +!el integer :: jjj +!el common /chuju/ jjj + real(kind=8) :: energia(0:n_ene) + real(kind=8) :: f + real(kind=8),external :: ufparm + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) +! if (jjj.gt.0) then +! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +! endif + nfl=nf + icg=mod(nf,2)+1 + call var_to_geom_restr(n,x) + call zerograd + call chainbuild +!d write (iout,*) 'ETOTAL called from FUNC' + call etotal(energia) + call sum_gradient + f=energia(0) +! if (jjj.gt.0) then +! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +! write (iout,*) 'f=',etot +! jjj=0 +! endif + return + end subroutine func_restr +!----------------------------------------------------------------------------- +! subroutine func(n,x,nf,f,uiparm,urparm,ufparm) in module energy +!----------------------------------------------------------------------------- + subroutine x2xx(x,xx,n) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' + integer :: n,i,ij,ig,igall + real(kind=8),dimension(6*nres) :: xx,x !(maxvar) (maxvar=6*maxres) + +!el allocate(varall(nvar)) allocated in alioc_ener_arrays + + do i=1,nvar + varall(i)=x(i) + enddo + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + xx(ig)=x(igall) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + xx(ig)=x(igall) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + xx(ig)=x(igall) + endif + endif + enddo + enddo + + n=ig + + return + end subroutine x2xx +!----------------------------------------------------------------------------- +!el subroutine xx2x(x,xx) in module math +!----------------------------------------------------------------------------- + subroutine minim_dc(etot,iretcode,nfun) + + use MPI_data + use energy, only: fdum,check_ecartint +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + integer,parameter :: liv=60 +! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.MINIM' +! include 'COMMON.CHAIN' + integer :: iretcode,nfun,k,i,j,lv,idum(1) + integer,dimension(liv) :: iv + real(kind=8) :: minval !,v(1:77+(6*nres)*(6*nres+17)/2) !(1:lv) + real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) +!el common /przechowalnia/ v + + real(kind=8) :: energia(0:n_ene) +! external func_dc,grad_dc ,fdum + logical :: not_done,change,reduce + real(kind=8) :: g(6*nres),f1,etot,rdum(1) !,fdum + + lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) + + if (.not. allocated(v)) allocate(v(1:lv)) + + call deflt(2,iv,liv,lv,v) +! 12 means fresh start, dont call deflt + iv(1)=12 +! max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +! max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +! controls output + iv(19)=2 +! selects output unit + iv(21)=0 + if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout +! 1 means to print out result + iv(22)=print_min_res +! 1 means to print out summary stats + iv(23)=print_min_stat +! 1 means to print initial x and d + iv(24)=print_min_ini +! min val for v(radfac) default is 0.1 + v(24)=0.1D0 +! max val for v(radfac) default is 4.0 + v(25)=2.0D0 +! v(25)=4.0D0 +! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +! the sumsl default is 0.1 + v(26)=0.1D0 +! false conv if (act fnctn decrease) .lt. v(34) +! the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +! absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +! relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +! controls initial step size + v(35)=1.0D-1 +! large vals of d correspond to small components of step + do i=1,6*nres + d(i)=1.0D-1 + enddo + + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + x(k)=dc(j,i) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + x(k)=dc(j,i+nres) + enddo + endif + enddo + call check_ecartint + call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum) + call check_ecartint + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo + call chainbuild_cart + +!d call zerograd +!d nf=0 +!d call func_dc(k,x,nf,f,idum,rdum,fdum) +!d call grad_dc(k,x,nf,g,idum,rdum,fdum) +!d +!d do i=1,k +!d x(i)=x(i)+1.0D-5 +!d call func_dc(k,x,nf,f1,idum,rdum,fdum) +!d x(i)=x(i)-1.0D-5 +!d print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 +!d enddo +!el--------------------- +! write (iout,'(/a)') & +! "Cartesian coordinates of the reference structure after SUMSL" +! write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & +! "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" +! do i=1,nres +! write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & +! restyp(itype(i)),i,(c(j,i),j=1,3),& +! (c(j,i+nres),j=1,3) +! enddo +!el---------------------------- + etot=v(10) + iretcode=iv(1) + nfun=iv(6) + return + end subroutine minim_dc +!----------------------------------------------------------------------------- + subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) + + use MPI_data + use energy, only: zerograd,etotal +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' + integer :: n,nf,k,i,j + real(kind=8) :: energia(0:n_ene) + real(kind=8),external :: ufparm + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) + real(kind=8) :: f + nfl=nf +!bad icg=mod(nf,2)+1 + icg=1 + + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo + call chainbuild_cart + + call zerograd + call etotal(energia) + f=energia(0) + +!d print *,'func_dc ',nf,nfl,f + + return + end subroutine func_dc +!----------------------------------------------------------------------------- + subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm) + + use MPI_data + use energy, only: cartgrad,zerograd,etotal +! use MD_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.SETUP' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.MD' +! include 'COMMON.IOUNITS' + real(kind=8),external :: ufparm + integer :: n,nf,i,j,k + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) + real(kind=8) :: f +! +!elwrite(iout,*) "jestesmy w grad dc" +! +!bad icg=mod(nf,2)+1 + icg=1 +!d print *,'grad_dc ',nf,nfl,nf-nfl+1,icg +!elwrite(iout,*) "jestesmy w grad dc nf-nfl+1", nf-nfl+1 + if (nf-nfl+1) 20,30,40 + 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm) +!d print *,20 + if (nf.eq.0) return + goto 40 + 30 continue +!d print *,30 + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo +!elwrite(iout,*) "jestesmy w grad dc" + call chainbuild_cart + +! +! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +! + 40 call cartgrad +!d print *,40 +!elwrite(iout,*) "jestesmy w grad dc" + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + g(k)=gcart(j,i) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + g(k)=gxcart(j,i) + enddo + endif + enddo +!elwrite(iout,*) "jestesmy w grad dc" + + return + end subroutine grad_dc +!----------------------------------------------------------------------------- +! minim_mcmf.F +!----------------------------------------------------------------------------- +#ifdef MPI + subroutine minim_mcmf + + use MPI_data + use csa_data + use energy, only: func,gradient,fdum +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' + integer,parameter :: liv=60 +! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.MINIM' +! real(kind=8) :: fdum +! external func,gradient,fdum +!el real(kind=4) :: ran1,ran2,ran3 +! include 'COMMON.SETUP' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) + real(kind=8),dimension(mxch*(mxch+1)/2+1) :: erg + real(kind=8),dimension(6*nres) :: d,garbage !(maxvar) (maxvar=6*maxres) +!el real(kind=8) :: v(1:77+(6*nres)*(6*nres+17)/2+1) + integer,dimension(6) :: indx + integer,dimension(liv) :: iv + integer :: lv,idum(1),nf ! + real(kind=8) :: rdum(1) + real(kind=8) :: przes(3),obrot(3,3),eee + logical :: non_conv + + integer,dimension(MPI_STATUS_SIZE) :: muster + + integer :: ichuj,i,ierr + real(kind=8) :: rad,ene0 + data rad /1.745329252d-2/ +!el common /przechowalnia/ v + + lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) + if (.not. allocated(v)) allocate(v(1:lv)) + + ichuj=0 + 10 continue + ichuj = ichuj + 1 + call mpi_recv(indx,6,mpi_integer,king,idint,CG_COMM,& + muster,ierr) + if (indx(1).eq.0) return +! print *, 'worker ',me,' received order ',n,ichuj + call mpi_recv(var,nvar,mpi_double_precision,& + king,idreal,CG_COMM,muster,ierr) + call mpi_recv(ene0,1,mpi_double_precision,& + king,idreal,CG_COMM,muster,ierr) +! print *, 'worker ',me,' var read ' + + + call deflt(2,iv,liv,lv,v) +! 12 means fresh start, dont call deflt + iv(1)=12 +! max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +! max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +! controls output + iv(19)=2 +! selects output unit +! iv(21)=iout + iv(21)=0 +! 1 means to print out result + iv(22)=0 +! 1 means to print out summary stats + iv(23)=0 +! 1 means to print initial x and d + iv(24)=0 +! min val for v(radfac) default is 0.1 + v(24)=0.1D0 +! max val for v(radfac) default is 4.0 + v(25)=2.0D0 +! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +! the sumsl default is 0.1 + v(26)=0.1D0 +! false conv if (act fnctn decrease) .lt. v(34) +! the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +! absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +! relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +! controls initial step size + v(35)=1.0D-1 +! large vals of d correspond to small components of step + do i=1,nphi + d(i)=1.0D-1 + enddo + do i=nphi+1,nvar + d(i)=1.0D-1 + enddo +! minimize energy + + call func(nvar,var,nf,eee,idum,rdum,fdum) + if(eee.gt.1.0d18) then +! print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +! print *,' energy before SUMSL =',eee +! print *,' aborting local minimization' + iv(1)=-1 + v(10)=eee + nf=1 + go to 201 + endif + + call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) +! find which conformation was returned from sumsl + nf=iv(7)+1 + 201 continue +! total # of ftn evaluations (for iwf=0, it includes all minimizations). + indx(4)=nf + indx(5)=iv(1) + eee=v(10) + + call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM,& + ierr) +! print '(a5,i3,15f10.5)', 'ENEX0',indx(1),v(10) + call mpi_send(var,nvar,mpi_double_precision,& + king,idreal,CG_COMM,ierr) + call mpi_send(eee,1,mpi_double_precision,king,idreal,& + CG_COMM,ierr) + call mpi_send(ene0,1,mpi_double_precision,king,idreal,& + CG_COMM,ierr) + go to 10 + return + end subroutine minim_mcmf +#endif +!----------------------------------------------------------------------------- +! rmdd.f +!----------------------------------------------------------------------------- +! algorithm 611, collected algorithms from acm. +! algorithm appeared in acm-trans. math. software, vol.9, no. 4, +! dec., 1983, p. 503-524. + integer function imdcon(k) +! + integer :: k +! +! *** return integer machine-dependent constants *** +! +! *** k = 1 means return standard output unit number. *** +! *** k = 2 means return alternate output unit number. *** +! *** k = 3 means return input unit number. *** +! (note -- k = 2, 3 are used only by test programs.) +! +! +++ port version follows... +! external i1mach +! integer i1mach +! integer mdperm(3) +! data mdperm(1)/2/, mdperm(2)/4/, mdperm(3)/1/ +! imdcon = i1mach(mdperm(k)) +! +++ end of port version +++ +! +! +++ non-port version follows... + integer :: mdcon(3) + data mdcon(1)/6/, mdcon(2)/8/, mdcon(3)/5/ + imdcon = mdcon(k) +! +++ end of non-port version +++ +! + 999 return +! *** last card of imdcon follows *** + end function imdcon +!----------------------------------------------------------------------------- + real(kind=8) function rmdcon(k) +! +! *** return machine dependent constants used by nl2sol *** +! +! +++ comments below contain data statements for various machines. +++ +! +++ to convert to another machine, place a c in column 1 of the +++ +! +++ data statement line(s) that correspond to the current machine +++ +! +++ and remove the c from column 1 of the data statement line(s) +++ +! +++ that correspond to the new machine. +++ +! + integer :: k +! +! *** the constant returned depends on k... +! +! *** k = 1... smallest pos. eta such that -eta exists. +! *** k = 2... square root of eta. +! *** k = 3... unit roundoff = smallest pos. no. machep such +! *** that 1 + machep .gt. 1 .and. 1 - machep .lt. 1. +! *** k = 4... square root of machep. +! *** k = 5... square root of big (see k = 6). +! *** k = 6... largest machine no. big such that -big exists. +! + real(kind=8) :: big, eta, machep + integer :: bigi(4), etai(4), machei(4) +!/+ +!el real(kind=8) :: dsqrt +!/ + equivalence (big,bigi(1)), (eta,etai(1)), (machep,machei(1)) +! +! +++ ibm 360, ibm 370, or xerox +++ +! +! data big/z7fffffffffffffff/, eta/z0010000000000000/, +! 1 machep/z3410000000000000/ +! +! +++ data general +++ +! +! data big/0.7237005577d+76/, eta/0.5397605347d-78/, +! 1 machep/2.22044605d-16/ +! +! +++ dec 11 +++ +! +! data big/1.7d+38/, eta/2.938735878d-39/, machep/2.775557562d-17/ +! +! +++ hp3000 +++ +! +! data big/1.157920892d+77/, eta/8.636168556d-78/, +! 1 machep/5.551115124d-17/ +! +! +++ honeywell +++ +! +! data big/1.69d+38/, eta/5.9d-39/, machep/2.1680435d-19/ +! +! +++ dec10 +++ +! +! data big/"377777100000000000000000/, +! 1 eta/"002400400000000000000000/, +! 2 machep/"104400000000000000000000/ +! +! +++ burroughs +++ +! +! data big/o0777777777777777,o7777777777777777/, +! 1 eta/o1771000000000000,o7770000000000000/, +! 2 machep/o1451000000000000,o0000000000000000/ +! +! +++ control data +++ +! +! data big/37767777777777777777b,37167777777777777777b/, +! 1 eta/00014000000000000000b,00000000000000000000b/, +! 2 machep/15614000000000000000b,15010000000000000000b/ +! +! +++ prime +++ +! +! data big/1.0d+9786/, eta/1.0d-9860/, machep/1.4210855d-14/ +! +! +++ univac +++ +! +! data big/8.988d+307/, eta/1.2d-308/, machep/1.734723476d-18/ +! +! +++ vax +++ +! + data big/1.7d+38/, eta/2.939d-39/, machep/1.3877788d-17/ +! +! +++ cray 1 +++ +! +! data bigi(1)/577767777777777777777b/, +! 1 bigi(2)/000007777777777777776b/, +! 2 etai(1)/200004000000000000000b/, +! 3 etai(2)/000000000000000000000b/, +! 4 machei(1)/377224000000000000000b/, +! 5 machei(2)/000000000000000000000b/ +! +! +++ port library -- requires more than just a data statement... +++ +! +! external d1mach +! double precision d1mach, zero +! data big/0.d+0/, eta/0.d+0/, machep/0.d+0/, zero/0.d+0/ +! if (big .gt. zero) go to 1 +! big = d1mach(2) +! eta = d1mach(1) +! machep = d1mach(4) +!1 continue +! +! +++ end of port +++ +! +!------------------------------- body -------------------------------- +! + go to (10, 20, 30, 40, 50, 60), k +! + 10 rmdcon = eta + go to 999 +! + 20 rmdcon = dsqrt(256.d+0*eta)/16.d+0 + go to 999 +! + 30 rmdcon = machep + go to 999 +! + 40 rmdcon = dsqrt(machep) + go to 999 +! + 50 rmdcon = dsqrt(big/256.d+0)*16.d+0 + go to 999 +! + 60 rmdcon = big +! + 999 return +! *** last card of rmdcon follows *** + end function rmdcon +!----------------------------------------------------------------------------- +! sc_move.F +!----------------------------------------------------------------------------- + subroutine sc_move(n_start,n_end,n_maxtry,e_drop,n_fun,etot) + + use control + use random, only: iran_num + use energy, only: esc +! Perform a quick search over side-chain arrangments (over +! residues n_start to n_end) for a given (frozen) CA trace +! Only side-chains are minimized (at most n_maxtry times each), +! not CA positions +! Stops if energy drops by e_drop, otherwise tries all residues +! in the given range +! If there is an energy drop, full minimization may be useful +! n_start, n_end CAN be modified by this routine, but only if +! out of bounds (n_start <= 1, n_end >= nres, n_start < n_end) +! NOTE: this move should never increase the energy +!rc implicit none + +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.HEADER' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' + +! External functions +!el integer iran_num +!el external iran_num + +! Input arguments + integer :: n_start,n_end,n_maxtry + real(kind=8) :: e_drop + +! Output arguments + integer :: n_fun + real(kind=8) :: etot + +! Local variables +! real(kind=8) :: energy(0:n_ene) + real(kind=8) :: cur_alph(2:nres-1),cur_omeg(2:nres-1) + real(kind=8) :: orig_e,cur_e + integer :: n,n_steps,n_first,n_cur,n_tot !,i + real(kind=8) :: orig_w(0:n_ene) + real(kind=8) :: wtime + +!elwrite(iout,*) "in sc_move etot= ", etot +! Set non side-chain weights to zero (minimization is faster) +! NOTE: e(2) does not actually depend on the side-chain, only CA + orig_w(2)=wscp + orig_w(3)=welec + orig_w(4)=wcorr + orig_w(5)=wcorr5 + orig_w(6)=wcorr6 + orig_w(7)=wel_loc + orig_w(8)=wturn3 + orig_w(9)=wturn4 + orig_w(10)=wturn6 + orig_w(11)=wang + orig_w(13)=wtor + orig_w(14)=wtor_d + orig_w(15)=wvdwpp + + wscp=0.D0 + welec=0.D0 + wcorr=0.D0 + wcorr5=0.D0 + wcorr6=0.D0 + wel_loc=0.D0 + wturn3=0.D0 + wturn4=0.D0 + wturn6=0.D0 + wang=0.D0 + wtor=0.D0 + wtor_d=0.D0 + wvdwpp=0.D0 + +! Make sure n_start, n_end are within proper range + if (n_start.lt.2) n_start=2 + if (n_end.gt.nres-1) n_end=nres-1 +!rc if (n_start.lt.n_end) then + if (n_start.gt.n_end) then + n_start=2 + n_end=nres-1 + endif + +! Save the initial values of energy and coordinates +!d call chainbuild +!d call etotal(energy) +!d write (iout,*) 'start sc ene',energy(0) +!d call enerprint(energy(0)) +!rc etot=energy(0) + n_fun=0 +!rc orig_e=etot +!rc cur_e=orig_e +!rc do i=2,nres-1 +!rc cur_alph(i)=alph(i) +!rc cur_omeg(i)=omeg(i) +!rc enddo + +!t wtime=MPI_WTIME() +! Try (one by one) all specified residues, starting from a +! random position in sequence +! Stop early if the energy has decreased by at least e_drop + n_tot=n_end-n_start+1 + n_first=iran_num(0,n_tot-1) + n_steps=0 + n=0 +!rc do while (n.lt.n_tot .and. orig_e-etot.lt.e_drop) + do while (n.lt.n_tot) + n_cur=n_start+mod(n_first+n,n_tot) + call single_sc_move(n_cur,n_maxtry,e_drop,& + n_steps,n_fun,etot) +!elwrite(iout,*) "after msingle sc_move etot= ", etot +! If a lower energy was found, update the current structure... +!rc if (etot.lt.cur_e) then +!rc cur_e=etot +!rc do i=2,nres-1 +!rc cur_alph(i)=alph(i) +!rc cur_omeg(i)=omeg(i) +!rc enddo +!rc else +! ...else revert to the previous one +!rc etot=cur_e +!rc do i=2,nres-1 +!rc alph(i)=cur_alph(i) +!rc omeg(i)=cur_omeg(i) +!rc enddo +!rc endif + n=n+1 +!d +!d call chainbuild +!d call etotal(energy) +!d print *,'running',n,energy(0) + enddo + +!d call chainbuild +!d call etotal(energy) +!d write (iout,*) 'end sc ene',energy(0) + +! Put the original weights back to calculate the full energy + wscp=orig_w(2) + welec=orig_w(3) + wcorr=orig_w(4) + wcorr5=orig_w(5) + wcorr6=orig_w(6) + wel_loc=orig_w(7) + wturn3=orig_w(8) + wturn4=orig_w(9) + wturn6=orig_w(10) + wang=orig_w(11) + wtor=orig_w(13) + wtor_d=orig_w(14) + wvdwpp=orig_w(15) + +!rc n_fun=n_fun+1 +!t write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime + return + end subroutine sc_move +!----------------------------------------------------------------------------- + subroutine single_sc_move(res_pick,n_maxtry,e_drop,n_steps,n_fun,e_sc) + +! Perturb one side-chain (res_pick) and minimize the +! neighbouring region, keeping all CA's and non-neighbouring +! side-chains fixed +! Try until e_drop energy improvement is achieved, or n_maxtry +! attempts have been made +! At the start, e_sc should contain the side-chain-only energy(0) +! nsteps and nfun for this move are ADDED to n_steps and n_fun +!rc implicit none + use energy, only: esc + use geometry, only:dist +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.CHAIN' +! include 'COMMON.MINIM' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' + +! External functions +!el double precision dist +!el external dist + +! Input arguments + integer :: res_pick,n_maxtry + real(kind=8) :: e_drop + +! Input/Output arguments + integer :: n_steps,n_fun + real(kind=8) :: e_sc + +! Local variables + logical :: fail + integer :: i,j + integer :: nres_moved + integer :: iretcode,loc_nfun,orig_maxfun,n_try + real(kind=8) :: sc_dist,sc_dist_cutoff +! real(kind=8) :: energy_(0:n_ene) + real(kind=8) :: evdw,escloc,orig_e,cur_e + real(kind=8) :: cur_alph(2:nres-1),cur_omeg(2:nres-1) + real(kind=8) :: var(6*nres) !(maxvar) (maxvar=6*maxres) + + real(kind=8) :: orig_theta(1:nres),orig_phi(1:nres),& + orig_alph(1:nres),orig_omeg(1:nres) + +!elwrite(iout,*) "in sinle etot/ e_sc",e_sc +! Define what is meant by "neighbouring side-chain" + sc_dist_cutoff=5.0D0 + +! Don't do glycine or ends + i=itype(res_pick) + if (i.eq.10 .or. i.eq.ntyp1) return + +! Freeze everything (later will relax only selected side-chains) + mask_r=.true. + do i=1,nres + mask_phi(i)=0 + mask_theta(i)=0 + mask_side(i)=0 + enddo + +! Find the neighbours of the side-chain to move +! and save initial variables +!rc orig_e=e_sc +!rc cur_e=orig_e + nres_moved=0 + do i=2,nres-1 +! Don't do glycine (itype(j)==10) + if (itype(i).ne.10) then + sc_dist=dist(nres+i,nres+res_pick) + else + sc_dist=sc_dist_cutoff + endif + if (sc_dist.lt.sc_dist_cutoff) then + nres_moved=nres_moved+1 + mask_side(i)=1 + cur_alph(i)=alph(i) + cur_omeg(i)=omeg(i) + endif + enddo + + call chainbuild + call egb1(evdw) + call esc(escloc) +!elwrite(iout,*) "in sinle etot/ e_sc",e_sc +!elwrite(iout,*) "in sinle wsc=",wsc,"evdw",evdw,"wscloc",wscloc,"escloc",escloc + e_sc=wsc*evdw+wscloc*escloc +!elwrite(iout,*) "in sinle etot/ e_sc",e_sc +!d call etotal(energy) +!d print *,'new ',(energy(k),k=0,n_ene) + orig_e=e_sc + cur_e=orig_e + + n_try=0 + do while (n_try.lt.n_maxtry .and. orig_e-cur_e.lt.e_drop) +! Move the selected residue (don't worry if it fails) + call gen_side(iabs(itype(res_pick)),theta(res_pick+1),& + alph(res_pick),omeg(res_pick),fail) + +! Minimize the side-chains starting from the new arrangement + call geom_to_var(nvar,var) + orig_maxfun=maxfun + maxfun=7 + +!rc do i=1,nres +!rc orig_theta(i)=theta(i) +!rc orig_phi(i)=phi(i) +!rc orig_alph(i)=alph(i) +!rc orig_omeg(i)=omeg(i) +!rc enddo + +!elwrite(iout,*) "in sinle etot/ e_sc",e_sc + call minimize_sc1(e_sc,var,iretcode,loc_nfun) + +!elwrite(iout,*) "in sinle etot/ e_sc",e_sc +!v write(*,'(2i3,2f12.5,2i3)') +!v & res_pick,nres_moved,orig_e,e_sc-cur_e, +!v & iretcode,loc_nfun + +!$$$ if (iretcode.eq.8) then +!$$$ write(iout,*)'Coordinates just after code 8' +!$$$ call chainbuild +!$$$ call all_varout +!$$$ call flush(iout) +!$$$ do i=1,nres +!$$$ theta(i)=orig_theta(i) +!$$$ phi(i)=orig_phi(i) +!$$$ alph(i)=orig_alph(i) +!$$$ omeg(i)=orig_omeg(i) +!$$$ enddo +!$$$ write(iout,*)'Coordinates just before code 8' +!$$$ call chainbuild +!$$$ call all_varout +!$$$ call flush(iout) +!$$$ endif + + n_fun=n_fun+loc_nfun + maxfun=orig_maxfun + call var_to_geom(nvar,var) + +! If a lower energy was found, update the current structure... + if (e_sc.lt.cur_e) then +!v call chainbuild +!v call etotal(energy) +!d call egb1(evdw) +!d call esc(escloc) +!d e_sc1=wsc*evdw+wscloc*escloc +!d print *,' new',e_sc1,energy(0) +!v print *,'new ',energy(0) +!d call enerprint(energy(0)) + cur_e=e_sc + do i=2,nres-1 + if (mask_side(i).eq.1) then + cur_alph(i)=alph(i) + cur_omeg(i)=omeg(i) + endif + enddo + else +! ...else revert to the previous one + e_sc=cur_e + do i=2,nres-1 + if (mask_side(i).eq.1) then + alph(i)=cur_alph(i) + omeg(i)=cur_omeg(i) + endif + enddo + endif + n_try=n_try+1 + + enddo + n_steps=n_steps+n_try + +! Reset the minimization mask_r to false + mask_r=.false. + + return + end subroutine single_sc_move +!----------------------------------------------------------------------------- + subroutine sc_minimize(etot,iretcode,nfun) + +! Minimizes side-chains only, leaving backbone frozen +!rc implicit none + use energy, only: etotal +! Includes +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.FFIELD' + +! Output arguments + real(kind=8) :: etot + integer :: iretcode,nfun + +! Local variables + integer :: i + real(kind=8) :: orig_w(0:n_ene),energy_(0:n_ene) + real(kind=8) :: var(6*nres) !(maxvar)(maxvar=6*maxres) + + +! Set non side-chain weights to zero (minimization is faster) +! NOTE: e(2) does not actually depend on the side-chain, only CA + orig_w(2)=wscp + orig_w(3)=welec + orig_w(4)=wcorr + orig_w(5)=wcorr5 + orig_w(6)=wcorr6 + orig_w(7)=wel_loc + orig_w(8)=wturn3 + orig_w(9)=wturn4 + orig_w(10)=wturn6 + orig_w(11)=wang + orig_w(13)=wtor + orig_w(14)=wtor_d + + wscp=0.D0 + welec=0.D0 + wcorr=0.D0 + wcorr5=0.D0 + wcorr6=0.D0 + wel_loc=0.D0 + wturn3=0.D0 + wturn4=0.D0 + wturn6=0.D0 + wang=0.D0 + wtor=0.D0 + wtor_d=0.D0 + +! Prepare to freeze backbone + do i=1,nres + mask_phi(i)=0 + mask_theta(i)=0 + mask_side(i)=1 + enddo + +! Minimize the side-chains + mask_r=.true. + call geom_to_var(nvar,var) + call minimize(etot,var,iretcode,nfun) + call var_to_geom(nvar,var) + mask_r=.false. + +! Put the original weights back and calculate the full energy + wscp=orig_w(2) + welec=orig_w(3) + wcorr=orig_w(4) + wcorr5=orig_w(5) + wcorr6=orig_w(6) + wel_loc=orig_w(7) + wturn3=orig_w(8) + wturn4=orig_w(9) + wturn6=orig_w(10) + wang=orig_w(11) + wtor=orig_w(13) + wtor_d=orig_w(14) + + call chainbuild + call etotal(energy_) + etot=energy_(0) + + return + end subroutine sc_minimize +!----------------------------------------------------------------------------- + subroutine minimize_sc1(etot,x,iretcode,nfun) + + use energy, only: func,gradient,fdum,etotal,enerprint + use comm_srutu +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer,parameter :: liv=60 + integer :: iretcode,nfun +! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.MINIM' +!el integer :: icall +!el common /srutu/ icall + integer,dimension(liv) :: iv + real(kind=8) :: minval !,v(1:77+(6*nres)*(6*nres+17)/2) !(1:lv) + real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) + real(kind=8) :: energia(0:n_ene) +!el real(kind=8) :: fdum +! external gradient,fdum !func, +! external func_restr1,grad_restr1 + logical :: not_done,change,reduce +!el common /przechowalnia/ v + + integer :: nvar_restr,lv,i,j + integer :: idum(1) + real(kind=8) :: rdum(1),etot !,fdum + + lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) + if (.not. allocated(v)) allocate(v(1:lv)) + + call deflt(2,iv,liv,lv,v) +! 12 means fresh start, dont call deflt + iv(1)=12 +! max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +! max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +! controls output + iv(19)=2 +! selects output unit +! iv(21)=iout + iv(21)=0 +! 1 means to print out result + iv(22)=0 +! 1 means to print out summary stats + iv(23)=0 +! 1 means to print initial x and d + iv(24)=0 +! min val for v(radfac) default is 0.1 + v(24)=0.1D0 +! max val for v(radfac) default is 4.0 + v(25)=2.0D0 +! v(25)=4.0D0 +! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +! the sumsl default is 0.1 + v(26)=0.1D0 +! false conv if (act fnctn decrease) .lt. v(34) +! the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +! absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +! relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +! controls initial step size + v(35)=1.0D-1 +! large vals of d correspond to small components of step + do i=1,nphi + d(i)=1.0D-1 + enddo + do i=nphi+1,nvar + d(i)=1.0D-1 + enddo +!elmask_r=.false. + IF (mask_r) THEN + call x2xx(x,xx,nvar_restr) + call sumsl(nvar_restr,d,xx,func_restr1,grad_restr1,& + iv,liv,lv,v,idum,rdum,fdum) + call xx2x(x,xx) + ELSE + call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) + ENDIF +!el--------------------- +! write (iout,'(/a)') & +! "Cartesian coordinates of the reference structure after SUMSL" +! write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & +! "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" +! do i=1,nres +! write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & +! restyp(itype(i)),i,(c(j,i),j=1,3),& +! (c(j,i+nres),j=1,3) +! enddo +! call etotal(energia) +! call enerprint(energia) +!el---------------------------- + etot=v(10) + iretcode=iv(1) + nfun=iv(6) + + return + end subroutine minimize_sc1 +!----------------------------------------------------------------------------- + subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) + + use comm_chu + use energy, only: zerograd,esc,sc_grad +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.DERIV' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.FFIELD' +! include 'COMMON.INTERACT' +! include 'COMMON.TIME1' + integer :: n,nf,i,j +!el common /chuju/ jjj + real(kind=8) :: energia(0:n_ene),evdw,escloc + real(kind=8) :: e1,e2,f + real(kind=8),external :: ufparm + integer :: uiparm(1) + real(kind=8) :: urparm(1) + real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) + nfl=nf + icg=mod(nf,2)+1 + +#ifdef OSF +! Intercept NaNs in the coordinates, before calling etotal + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + FOUND_NAN=.false. + if (x_sum.ne.x_sum) then + write(iout,*)" *** func_restr1 : Found NaN in coordinates" + f=1.0D+73 + FOUND_NAN=.true. + return + endif +#endif + + call var_to_geom_restr(n,x) + call zerograd + call chainbuild +!d write (iout,*) 'ETOTAL called from FUNC' + call egb1(evdw) + call esc(escloc) + f=wsc*evdw+wscloc*escloc +!d call etotal(energia(0)) +!d f=wsc*energia(1)+wscloc*energia(12) +!d print *,f,evdw,escloc,energia(0) +! +! Sum up the components of the Cartesian gradient. +! + do i=1,nct + do j=1,3 + gradx(j,i,icg)=wsc*gvdwx(j,i) + enddo + enddo + + return + end subroutine func_restr1 +!----------------------------------------------------------------------------- + subroutine grad_restr1(n,x,nf,g,uiparm,urparm,ufparm) + + use energy, only: cartder,zerograd,esc,sc_grad +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +!el external ufparm + integer :: i,j,k,ind,n,nf,uiparm(1) + real(kind=8) :: f,urparm(1) + real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) + integer :: ig,igall,ij + real(kind=8) :: gphii,gthetai,galphai,gomegai + real(kind=8),external :: ufparm + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr1(n,x,nf,f,uiparm,urparm,ufparm) +! write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom_restr(n,x) + call chainbuild +! +! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +! + 40 call cartder +! +! Convert the Cartesian gradient into internal-coordinate gradient. +! + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +! +! Add the components corresponding to local energy terms. +! + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +!d do i=1,ig +!d write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +!d enddo + return + end subroutine grad_restr1 +!----------------------------------------------------------------------------- + subroutine egb1(evdw) +! +! This subroutine calculates the interaction energy of nonbonded side chains +! assuming the Gay-Berne potential of interaction. +! + use calc_data + use energy, only: sc_grad +! use control, only:stopx +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.LOCAL' +! include 'COMMON.CHAIN' +! include 'COMMON.DERIV' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CALC' +! include 'COMMON.CONTROL' + logical :: lprn + real(kind=8) :: evdw +!el local variables + integer :: iint,ind,itypi,itypi1,itypj + real(kind=8) :: xi,yi,zi,rrij,sig,sig0ij,rij_shift,fac,e1,e2,& + sigm,epsi +!elwrite(iout,*) "check evdw" +! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +! if (icall.eq.0) lprn=.true. + ind=0 + do i=iatsc_s,iatsc_e + + itypi=iabs(itype(i)) + itypi1=iabs(itype(i+1)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=dsc_inv(itypi) +!elwrite(iout,*) itypi,itypi1,xi,yi,zi,dxi,dyi,dzi,dsci_inv +! +! Calculate SC interaction energy. +! + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN + ind=ind+1 + itypj=iabs(itype(j)) + dscj_inv=dsc_inv(itypj) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) +! For diagnostics only!!! +! chi1=0.0D0 +! chi2=0.0D0 +! chi12=0.0D0 +! chip1=0.0D0 +! chip2=0.0D0 +! chip12=0.0D0 +! alf1=0.0D0 +! alf2=0.0D0 +! alf12=0.0D0 + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) +! Calculate angle-dependent terms of energy and contributions to their +! derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij +! I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 +!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') & +!d restyp(itypi),i,restyp(itypj),j, & +!d rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) + return + endif + sigder=-sig*sigsq +!--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') & +!d restyp(itypi),i,restyp(itypj),j, & +!d epsi,sigm,chi1,chi2,chip1,chip2, & +!d eps1,eps2rt**2,eps3rt**2,sig,sig0ij, & +!d om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, & +!d evdwij + endif + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & + 'evdw',i,j,evdwij + +! Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac +! Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +! Calculate angular part of the gradient. + +!elwrite(iout,*) evdw + call sc_grad +!elwrite(iout,*) "evdw=",evdw,j,iint,i + ENDIF +!elwrite(iout,*) evdw + enddo ! j +!elwrite(iout,*) evdw + enddo ! iint +!elwrite(iout,*) evdw + enddo ! i +!elwrite(iout,*) evdw,i + end subroutine egb1 +!----------------------------------------------------------------------------- +! sumsld.f +!----------------------------------------------------------------------------- + subroutine sumsl(n,d,x,calcf,calcg,iv,liv,lv,v,uiparm,urparm,ufparm) +! +! *** minimize general unconstrained objective function using *** +! *** analytic gradient and hessian approx. from secant update *** +! +! use control + integer :: n, liv, lv + integer :: iv(liv), uiparm(1) + real(kind=8) :: d(n), x(n), v(lv), urparm(1) + real(kind=8),external :: ufparm !funtion name as an argument + +! dimension v(71 + n*(n+15)/2), uiparm(*), urparm(*) + external :: calcf, calcg !subroutine name as an argument +! +! *** purpose *** +! +! this routine interacts with subroutine sumit in an attempt +! to find an n-vector x* that minimizes the (unconstrained) +! objective function computed by calcf. (often the x* found is +! a local minimizer rather than a global one.) +! +!-------------------------- parameter usage -------------------------- +! +! n........ (input) the number of variables on which f depends, i.e., +! the number of components in x. +! d........ (input/output) a scale vector such that d(i)*x(i), +! i = 1,2,...,n, are all in comparable units. +! d can strongly affect the behavior of sumsl. +! finding the best choice of d is generally a trial- +! and-error process. choosing d so that d(i)*x(i) +! has about the same value for all i often works well. +! the defaults provided by subroutine deflt (see i +! below) require the caller to supply d. +! x........ (input/output) before (initially) calling sumsl, the call- +! er should set x to an initial guess at x*. when +! sumsl returns, x contains the best point so far +! found, i.e., the one that gives the least value so +! far seen for f(x). +! calcf.... (input) a subroutine that, given x, computes f(x). calcf +! must be declared external in the calling program. +! it is invoked by +! call calcf(n, x, nf, f, uiparm, urparm, ufparm) +! when calcf is called, nf is the invocation +! count for calcf. nf is included for possible use +! with calcg. if x is out of bounds (e.g., if it +! would cause overflow in computing f(x)), then calcf +! should set nf to 0. this will cause a shorter step +! to be attempted. (if x is in bounds, then calcf +! should not change nf.) the other parameters are as +! described above and below. calcf should not change +! n, p, or x. +! calcg.... (input) a subroutine that, given x, computes g(x), the gra- +! dient of f at x. calcg must be declared external in +! the calling program. it is invoked by +! call calcg(n, x, nf, g, uiparm, urparm, ufaprm) +! when calcg is called, nf is the invocation +! count for calcf at the time f(x) was evaluated. the +! x passed to calcg is usually the one passed to calcf +! on either its most recent invocation or the one +! prior to it. if calcf saves intermediate results +! for use by calcg, then it is possible to tell from +! nf whether they are valid for the current x (or +! which copy is valid if two copies are kept). if g +! cannot be computed at x, then calcg should set nf to +! 0. in this case, sumsl will return with iv(1) = 65. +! (if g can be computed at x, then calcg should not +! changed nf.) the other parameters to calcg are as +! described above and below. calcg should not change +! n or x. +! iv....... (input/output) an integer value array of length liv (see +! below) that helps control the sumsl algorithm and +! that is used to store various intermediate quanti- +! ties. of particular interest are the initialization/ +! return code iv(1) and the entries in iv that control +! printing and limit the number of iterations and func- +! tion evaluations. see the section on iv input +! values below. +! liv...... (input) length of iv array. must be at least 60. if li +! is too small, then sumsl returns with iv(1) = 15. +! when sumsl returns, the smallest allowed value of +! liv is stored in iv(lastiv) -- see the section on +! iv output values below. (this is intended for use +! with extensions of sumsl that handle constraints.) +! lv....... (input) length of v array. must be at least 71+n*(n+15)/2. +! (at least 77+n*(n+17)/2 for smsno, at least +! 78+n*(n+12) for humsl). if lv is too small, then +! sumsl returns with iv(1) = 16. when sumsl returns, +! the smallest allowed value of lv is stored in +! iv(lastv) -- see the section on iv output values +! below. +! v........ (input/output) a floating-point value array of length l +! (see below) that helps control the sumsl algorithm +! and that is used to store various intermediate +! quantities. of particular interest are the entries +! in v that limit the length of the first step +! attempted (lmax0) and specify convergence tolerances +! (afctol, lmaxs, rfctol, sctol, xctol, xftol). +! uiparm... (input) user integer parameter array passed without change +! to calcf and calcg. +! urparm... (input) user floating-point parameter array passed without +! change to calcf and calcg. +! ufparm... (input) user external subroutine or function passed without +! change to calcf and calcg. +! +! *** iv input values (from subroutine deflt) *** +! +! iv(1)... on input, iv(1) should have a value between 0 and 14...... +! 0 and 12 mean this is a fresh start. 0 means that +! deflt(2, iv, liv, lv, v) +! is to be called to provide all default values to iv and +! v. 12 (the value that deflt assigns to iv(1)) means the +! caller has already called deflt and has possibly changed +! some iv and/or v entries to non-default values. +! 13 means deflt has been called and that sumsl (and +! sumit) should only do their storage allocation. that is, +! they should set the output components of iv that tell +! where various subarrays arrays of v begin, such as iv(g) +! (and, for humsl and humit only, iv(dtol)), and return. +! 14 means that a storage has been allocated (by a call +! with iv(1) = 13) and that the algorithm should be +! started. when called with iv(1) = 13, sumsl returns +! iv(1) = 14 unless liv or lv is too small (or n is not +! positive). default = 12. +! iv(inith).... iv(25) tells whether the hessian approximation h should +! be initialized. 1 (the default) means sumit should +! initialize h to the diagonal matrix whose i-th diagonal +! element is d(i)**2. 0 means the caller has supplied a +! cholesky factor l of the initial hessian approximation +! h = l*(l**t) in v, starting at v(iv(lmat)) = v(iv(42)) +! (and stored compactly by rows). note that iv(lmat) may +! be initialized by calling sumsl with iv(1) = 13 (see +! the iv(1) discussion above). default = 1. +! iv(mxfcal)... iv(17) gives the maximum number of function evaluations +! (calls on calcf) allowed. if this number does not suf- +! fice, then sumsl returns with iv(1) = 9. default = 200. +! iv(mxiter)... iv(18) gives the maximum number of iterations allowed. +! it also indirectly limits the number of gradient evalua- +! tions (calls on calcg) to iv(mxiter) + 1. if iv(mxiter) +! iterations do not suffice, then sumsl returns with +! iv(1) = 10. default = 150. +! iv(outlev)... iv(19) controls the number and length of iteration sum- +! mary lines printed (by itsum). iv(outlev) = 0 means do +! not print any summary lines. otherwise, print a summary +! line after each abs(iv(outlev)) iterations. if iv(outlev) +! is positive, then summary lines of length 78 (plus carri- +! age control) are printed, including the following... the +! iteration and function evaluation counts, f = the current +! function value, relative difference in function values +! achieved by the latest step (i.e., reldf = (f0-v(f))/f01, +! where f01 is the maximum of abs(v(f)) and abs(v(f0)) and +! v(f0) is the function value from the previous itera- +! tion), the relative function reduction predicted for the +! step just taken (i.e., preldf = v(preduc) / f01, where +! v(preduc) is described below), the scaled relative change +! in x (see v(reldx) below), the step parameter for the +! step just taken (stppar = 0 means a full newton step, +! between 0 and 1 means a relaxed newton step, between 1 +! and 2 means a double dogleg step, greater than 2 means +! a scaled down cauchy step -- see subroutine dbldog), the +! 2-norm of the scale vector d times the step just taken +! (see v(dstnrm) below), and npreldf, i.e., +! v(nreduc)/f01, where v(nreduc) is described below -- if +! npreldf is positive, then it is the relative function +! reduction predicted for a newton step (one with +! stppar = 0). if npreldf is negative, then it is the +! negative of the relative function reduction predicted +! for a step computed with step bound v(lmaxs) for use in +! testing for singular convergence. +! if iv(outlev) is negative, then lines of length 50 +! are printed, including only the first 6 items listed +! above (through reldx). +! default = 1. +! iv(parprt)... iv(20) = 1 means print any nondefault v values on a +! fresh start or any changed v values on a restart. +! iv(parprt) = 0 means skip this printing. default = 1. +! iv(prunit)... iv(21) is the output unit number on which all printing +! is done. iv(prunit) = 0 means suppress all printing. +! default = standard output unit (unit 6 on most systems). +! iv(solprt)... iv(22) = 1 means print out the value of x returned (as +! well as the gradient and the scale vector d). +! iv(solprt) = 0 means skip this printing. default = 1. +! iv(statpr)... iv(23) = 1 means print summary statistics upon return- +! ing. these consist of the function value, the scaled +! relative change in x caused by the most recent step (see +! v(reldx) below), the number of function and gradient +! evaluations (calls on calcf and calcg), and the relative +! function reductions predicted for the last step taken and +! for a newton step (or perhaps a step bounded by v(lmaxs) +! -- see the descriptions of preldf and npreldf under +! iv(outlev) above). +! iv(statpr) = 0 means skip this printing. +! iv(statpr) = -1 means skip this printing as well as that +! of the one-line termination reason message. default = 1. +! iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d +! (on a fresh start only). iv(x0prt) = 0 means skip this +! printing. default = 1. +! +! *** (selected) iv output values *** +! +! iv(1)........ on output, iv(1) is a return code.... +! 3 = x-convergence. the scaled relative difference (see +! v(reldx)) between the current parameter vector x and +! a locally optimal parameter vector is very likely at +! most v(xctol). +! 4 = relative function convergence. the relative differ- +! ence between the current function value and its lo- +! cally optimal value is very likely at most v(rfctol). +! 5 = both x- and relative function convergence (i.e., the +! conditions for iv(1) = 3 and iv(1) = 4 both hold). +! 6 = absolute function convergence. the current function +! value is at most v(afctol) in absolute value. +! 7 = singular convergence. the hessian near the current +! iterate appears to be singular or nearly so, and a +! step of length at most v(lmaxs) is unlikely to yield +! a relative function decrease of more than v(sctol). +! 8 = false convergence. the iterates appear to be converg- +! ing to a noncritical point. this may mean that the +! convergence tolerances (v(afctol), v(rfctol), +! v(xctol)) are too small for the accuracy to which +! the function and gradient are being computed, that +! there is an error in computing the gradient, or that +! the function or gradient is discontinuous near x. +! 9 = function evaluation limit reached without other con- +! vergence (see iv(mxfcal)). +! 10 = iteration limit reached without other convergence +! (see iv(mxiter)). +! 11 = stopx returned .true. (external interrupt). see the +! usage notes below. +! 14 = storage has been allocated (after a call with +! iv(1) = 13). +! 17 = restart attempted with n changed. +! 18 = d has a negative component and iv(dtype) .le. 0. +! 19...43 = v(iv(1)) is out of range. +! 63 = f(x) cannot be computed at the initial x. +! 64 = bad parameters passed to assess (which should not +! occur). +! 65 = the gradient could not be computed at x (see calcg +! above). +! 67 = bad first parameter to deflt. +! 80 = iv(1) was out of range. +! 81 = n is not positive. +! iv(g)........ iv(28) is the starting subscript in v of the current +! gradient vector (the one corresponding to x). +! iv(lastiv)... iv(44) is the least acceptable value of liv. (it is +! only set if liv is at least 44.) +! iv(lastv).... iv(45) is the least acceptable value of lv. (it is +! only set if liv is large enough, at least iv(lastiv).) +! iv(nfcall)... iv(6) is the number of calls so far made on calcf (i.e., +! function evaluations). +! iv(ngcall)... iv(30) is the number of gradient evaluations (calls on +! calcg). +! iv(niter).... iv(31) is the number of iterations performed. +! +! *** (selected) v input values (from subroutine deflt) *** +! +! v(bias)..... v(43) is the bias parameter used in subroutine dbldog -- +! see that subroutine for details. default = 0.8. +! v(afctol)... v(31) is the absolute function convergence tolerance. +! if sumsl finds a point where the function value is less +! than v(afctol) in absolute value, and if sumsl does not +! return with iv(1) = 3, 4, or 5, then it returns with +! iv(1) = 6. this test can be turned off by setting +! v(afctol) to zero. default = max(10**-20, machep**2), +! where machep is the unit roundoff. +! v(dinit).... v(38), if nonnegative, is the value to which the scale +! vector d is initialized. default = -1. +! v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the +! very first step that sumsl attempts. this parameter can +! markedly affect the performance of sumsl. +! v(lmaxs).... v(36) is used in testing for singular convergence -- if +! the function reduction predicted for a step of length +! bounded by v(lmaxs) is at most v(sctol) * abs(f0), where +! f0 is the function value at the start of the current +! iteration, and if sumsl does not return with iv(1) = 3, +! 4, 5, or 6, then it returns with iv(1) = 7. default = 1. +! v(rfctol)... v(32) is the relative function convergence tolerance. +! if the current model predicts a maximum possible function +! reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) +! at the start of the current iteration, where f0 is the +! then current function value, and if the last step attempt- +! ed achieved no more than twice the predicted function +! decrease, then sumsl returns with iv(1) = 4 (or 5). +! default = max(10**-10, machep**(2/3)), where machep is +! the unit roundoff. +! v(sctol).... v(37) is the singular convergence tolerance -- see the +! description of v(lmaxs) above. +! v(tuner1)... v(26) helps decide when to check for false convergence. +! this is done if the actual function decrease from the +! current step is no more than v(tuner1) times its predict- +! ed value. default = 0.1. +! v(xctol).... v(33) is the x-convergence tolerance. if a newton step +! (see v(nreduc)) is tried that has v(reldx) .le. v(xctol) +! and if this step yields at most twice the predicted func- +! tion decrease, then sumsl returns with iv(1) = 3 (or 5). +! (see the description of v(reldx) below.) +! default = machep**0.5, where machep is the unit roundoff. +! v(xftol).... v(34) is the false convergence tolerance. if a step is +! tried that gives no more than v(tuner1) times the predict- +! ed function decrease and that has v(reldx) .le. v(xftol), +! and if sumsl does not return with iv(1) = 3, 4, 5, 6, or +! 7, then it returns with iv(1) = 8. (see the description +! of v(reldx) below.) default = 100*machep, where +! machep is the unit roundoff. +! v(*)........ deflt supplies to v a number of tuning constants, with +! which it should ordinarily be unnecessary to tinker. see +! section 17 of version 2.2 of the nl2sol usage summary +! (i.e., the appendix to ref. 1) for details on v(i), +! i = decfac, incfac, phmnfc, phmxfc, rdfcmn, rdfcmx, +! tuner2, tuner3, tuner4, tuner5. +! +! *** (selected) v output values *** +! +! v(dgnorm)... v(1) is the 2-norm of (diag(d)**-1)*g, where g is the +! most recently computed gradient. +! v(dstnrm)... v(2) is the 2-norm of diag(d)*step, where step is the +! current step. +! v(f)........ v(10) is the current function value. +! v(f0)....... v(13) is the function value at the start of the current +! iteration. +! v(nreduc)... v(6), if positive, is the maximum function reduction +! possible according to the current model, i.e., the func- +! tion reduction predicted for a newton step (i.e., +! step = -h**-1 * g, where g is the current gradient and +! h is the current hessian approximation). +! if v(nreduc) is negative, then it is the negative of +! the function reduction predicted for a step computed with +! a step bound of v(lmaxs) for use in testing for singular +! convergence. +! v(preduc)... v(7) is the function reduction predicted (by the current +! quadratic model) for the current step. this (divided by +! v(f0)) is used in testing for relative function +! convergence. +! v(reldx).... v(17) is the scaled relative change in x caused by the +! current step, computed as +! max(abs(d(i)*(x(i)-x0(i)), 1 .le. i .le. p) / +! max(d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p), +! where x = x0 + step. +! +!------------------------------- notes ------------------------------- +! +! *** algorithm notes *** +! +! this routine uses a hessian approximation computed from the +! bfgs update (see ref 3). only a cholesky factor of the hessian +! approximation is stored, and this is updated using ideas from +! ref. 4. steps are computed by the double dogleg scheme described +! in ref. 2. the steps are assessed as in ref. 1. +! +! *** usage notes *** +! +! after a return with iv(1) .le. 11, it is possible to restart, +! i.e., to change some of the iv and v input values described above +! and continue the algorithm from the point where it was interrupt- +! ed. iv(1) should not be changed, nor should any entries of i +! and v other than the input values (those supplied by deflt). +! those who do not wish to write a calcg which computes the +! gradient analytically should call smsno rather than sumsl. +! smsno uses finite differences to compute an approximate gradient. +! those who would prefer to provide f and g (the function and +! gradient) by reverse communication rather than by writing subrou- +! tines calcf and calcg may call on sumit directly. see the com- +! ments at the beginning of sumit. +! those who use sumsl interactively may wish to supply their +! own stopx function, which should return .true. if the break key +! has been pressed since stopx was last invoked. this makes it +! possible to externally interrupt sumsl (which will return with +! iv(1) = 11 if stopx returns .true.). +! storage for g is allocated at the end of v. thus the caller +! may make v longer than specified above and may allow calcg to use +! elements of g beyond the first n as scratch storage. +! +! *** portability notes *** +! +! the sumsl distribution tape contains both single- and double- +! precision versions of the sumsl source code, so it should be un- +! necessary to change precisions. +! only the functions imdcon and rmdcon contain machine-dependent +! constants. to change from one machine to another, it should +! suffice to change the (few) relevant lines in these functions. +! intrinsic functions are explicitly declared. on certain com- +! puters (e.g. univac), it may be necessary to comment out these +! declarations. so that this may be done automatically by a simple +! program, such declarations are preceded by a comment having c/+ +! in columns 1-3 and blanks in columns 4-72 and are followed by +! a comment having c/ in columns 1 and 2 and blanks in columns 3-72. +! the sumsl source code is expressed in 1966 ansi standard +! fortran. it may be converted to fortran 77 by commenting out all +! lines that fall between a line having c/6 in columns 1-3 and a +! line having c/7 in columns 1-3 and by removing (i.e., replacing +! by a blank) the c in column 1 of the lines that follow the c/7 +! line and precede a line having c/ in columns 1-2 and blanks in +! columns 3-72. these changes convert some data statements into +! parameter statements, convert some variables from real to +! character*4, and make the data statements that initialize these +! variables use character strings delimited by primes instead +! of hollerith constants. (such variables and data statements +! appear only in modules itsum and parck. parameter statements +! appear nearly everywhere.) these changes also add save state- +! ments for variables given machine-dependent constants by rmdcon. +! +! *** references *** +! +! 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), algorithm 573 -- +! an adaptive nonlinear least-squares algorithm, acm trans. +! math. software 7, pp. 369-383. +! +! 2. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- +! mization algorithms which use function and gradient +! values, j. optim. theory applic. 28, pp. 453-482. +! +! 3. dennis, j.e., and more, j.j. (1977), quasi-newton methods, motiva- +! tion and theory, siam rev. 19, pp. 46-89. +! +! 4. goldfarb, d. (1976), factorized variable metric methods for uncon- +! strained optimization, math. comput. 30, pp. 796-811. +! +! *** general *** +! +! coded by david m. gay (winter 1980). revised summer 1982. +! this subroutine was written in connection with research +! supported in part by the national science foundation under +! grants mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, +! and mcs-7906671. +!. +! +!---------------------------- declarations --------------------------- +! +!el external deflt, sumit +! +! deflt... supplies default iv and v input components. +! sumit... reverse-communication routine that carries out sumsl algo- +! rithm. +! + integer :: g1, iv1, nf + real(kind=8) :: f +! +! *** subscripts for iv *** +! +!el integer nextv, nfcall, nfgcal, g, toobig, vneed +! +!/6 +! data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, toobig/2/, vneed/4/ +!/7 + integer,parameter :: nextv=47, nfcall=6, nfgcal=7, g=28,& + toobig=2, vneed=4 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! +!elwrite(iout,*) "in sumsl" + if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) + iv1 = iv(1) + if (iv1 .eq. 12 .or. iv1 .eq. 13) iv(vneed) = iv(vneed) + n + if (iv1 .eq. 14) go to 10 + if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 + g1 = 1 + if (iv1 .eq. 12) iv(1) = 13 + go to 20 +! + 10 g1 = iv(g) +!elwrite(iout,*) "in sumsl go to 10" + +! +!elwrite(iout,*) "in sumsl" + 20 call sumit(d, f, v(g1), iv, liv, lv, n, v, x) +!elwrite(iout,*) "in sumsl, go to 20" + +!elwrite(iout,*) "in sumsl, go to 20, po sumit" +!elwrite(iout,*) "in sumsl iv()", iv(1)-2 + if (iv(1) - 2) 30, 40, 50 +! + 30 nf = iv(nfcall) +!elwrite(iout,*) "in sumsl iv",iv(nfcall) + call calcf(n, x, nf, f, uiparm, urparm, ufparm) +!elwrite(iout,*) "in sumsl" + if (nf .le. 0) iv(toobig) = 1 + go to 20 +! +!elwrite(iout,*) "in sumsl" + 40 call calcg(n, x, iv(nfgcal), v(g1), uiparm, urparm, ufparm) +!elwrite(iout,*) "in sumsl" + go to 20 +! + 50 if (iv(1) .ne. 14) go to 999 +! +! *** storage allocation +! + iv(g) = iv(nextv) + iv(nextv) = iv(g) + n + if (iv1 .ne. 13) go to 10 +!elwrite(iout,*) "in sumsl" +! + 999 return +! *** last card of sumsl follows *** + end subroutine sumsl +!----------------------------------------------------------------------------- + subroutine sumit(d,fx,g,iv,liv,lv,n,v,x) + + use control, only:stopx +! +! *** carry out sumsl (unconstrained minimization) iterations, using +! *** double-dogleg/bfgs steps. +! +! *** parameter declarations *** +! + integer :: liv, lv, n + integer :: iv(liv) + real(kind=8) :: d(n), fx, g(n), v(lv), x(n) +! +!-------------------------- parameter usage -------------------------- +! +! d.... scale vector. +! fx... function value. +! g.... gradient vector. +! iv... integer value array. +! liv.. length of iv (at least 60). +! lv... length of v (at least 71 + n*(n+13)/2). +! n.... number of variables (components in x and g). +! v.... floating-point value array. +! x.... vector of parameters to be optimized. +! +! *** discussion *** +! +! parameters iv, n, v, and x are the same as the corresponding +! ones to sumsl (which see), except that v can be shorter (since +! the part of v that sumsl uses for storing g is not needed). +! moreover, compared with sumsl, iv(1) may have the two additional +! output values 1 and 2, which are explained below, as is the use +! of iv(toobig) and iv(nfgcal). the value iv(g), which is an +! output value from sumsl (and smsno), is not referenced by +! sumit or the subroutines it calls. +! fx and g need not have been initialized when sumit is called +! with iv(1) = 12, 13, or 14. +! +! iv(1) = 1 means the caller should set fx to f(x), the function value +! at x, and call sumit again, having changed none of the +! other parameters. an exception occurs if f(x) cannot be +! (e.g. if overflow would occur), which may happen because +! of an oversized step. in this case the caller should set +! iv(toobig) = iv(2) to 1, which will cause sumit to ig- +! nore fx and try a smaller step. the parameter nf that +! sumsl passes to calcf (for possible use by calcg) is a +! copy of iv(nfcall) = iv(6). +! iv(1) = 2 means the caller should set g to g(x), the gradient vector +! of f at x, and call sumit again, having changed none of +! the other parameters except possibly the scale vector d +! when iv(dtype) = 0. the parameter nf that sumsl passes +! to calcg is iv(nfgcal) = iv(7). if g(x) cannot be +! evaluated, then the caller may set iv(nfgcal) to 0, in +! which case sumit will return with iv(1) = 65. +!. +! *** general *** +! +! coded by david m. gay (december 1979). revised sept. 1982. +! this subroutine was written in connection with research supported +! in part by the national science foundation under grants +! mcs-7600324 and mcs-7906671. +! +! (see sumsl for references.) +! +!+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ +! +! *** local variables *** +! + integer :: dg1, dummy, g01, i, k, l, lstgst, nwtst1, step1,& + temp1, w, x01, z + real(kind=8) :: t +!el logical :: lstopx +! +! *** constants *** +! +!el real(kind=8) :: half, negone, one, onep2, zero +! +! *** no intrinsic functions *** +! +! *** external functions and subroutines *** +! +!el external assst, dbdog, deflt, dotprd, itsum, litvmu, livmul, +!el 1 ltvmul, lupdat, lvmul, parck, reldst, stopx, vaxpy, +!el 2 vcopy, vscopy, vvmulp, v2norm, wzbfgs +!el logical stopx +!el real(kind=8) :: dotprd, reldst, v2norm +! +! assst.... assesses candidate step. +! dbdog.... computes double-dogleg (candidate) step. +! deflt.... supplies default iv and v input components. +! dotprd... returns inner product of two vectors. +! itsum.... prints iteration summary and info on initial and final x. +! litvmu... multiplies inverse transpose of lower triangle times vector. +! livmul... multiplies inverse of lower triangle times vector. +! ltvmul... multiplies transpose of lower triangle times vector. +! lupdt.... updates cholesky factor of hessian approximation. +! lvmul.... multiplies lower triangle times vector. +! parck.... checks validity of input iv and v values. +! reldst... computes v(reldx) = relative step size. +! stopx.... returns .true. if the break key has been pressed. +! vaxpy.... computes scalar times one vector plus another. +! vcopy.... copies one vector to another. +! vscopy... sets all elements of a vector to a scalar. +! vvmulp... multiplies vector by vector raised to power (componentwise). +! v2norm... returns the 2-norm of a vector. +! wzbfgs... computes w and z for lupdat corresponding to bfgs update. +! +! *** subscripts for iv and v *** +! +!el integer afctol +!el integer cnvcod, dg, dgnorm, dinit, dstnrm, dst0, f, f0, fdif, +!el 1 gthg, gtstep, g0, incfac, inith, irc, kagqt, lmat, lmax0, +!el 2 lmaxs, mode, model, mxfcal, mxiter, nextv, nfcall, nfgcal, +!el 3 ngcall, niter, nreduc, nwtstp, preduc, radfac, radinc, +!el 4 radius, rad0, reldx, restor, step, stglim, stlstg, toobig, +!el 5 tuner4, tuner5, vneed, xirc, x0 +! +! *** iv subscript values *** +! +!/6 +! data cnvcod/55/, dg/37/, g0/48/, inith/25/, irc/29/, kagqt/33/, +! 1 mode/35/, model/5/, mxfcal/17/, mxiter/18/, nfcall/6/, +! 2 nfgcal/7/, ngcall/30/, niter/31/, nwtstp/34/, radinc/8/, +! 3 restor/9/, step/40/, stglim/11/, stlstg/41/, toobig/2/, +! 4 vneed/4/, xirc/13/, x0/43/ +!/7 + integer,parameter :: cnvcod=55, dg=37, g0=48, inith=25, irc=29, kagqt=33,& + mode=35, model=5, mxfcal=17, mxiter=18, nfcall=6,& + nfgcal=7, ngcall=30, niter=31, nwtstp=34, radinc=8,& + restor=9, step=40, stglim=11, stlstg=41, toobig=2,& + vneed=4, xirc=13, x0=43 +!/ +! +! *** v subscript values *** +! +!/6 +! data afctol/31/ +! data dgnorm/1/, dinit/38/, dstnrm/2/, dst0/3/, f/10/, f0/13/, +! 1 fdif/11/, gthg/44/, gtstep/4/, incfac/23/, lmat/42/, +! 2 lmax0/35/, lmaxs/36/, nextv/47/, nreduc/6/, preduc/7/, +! 3 radfac/16/, radius/8/, rad0/9/, reldx/17/, tuner4/29/, +! 4 tuner5/30/ +!/7 + integer,parameter :: afctol=31 + integer,parameter :: dgnorm=1, dinit=38, dstnrm=2, dst0=3, f=10, f0=13,& + fdif=11, gthg=44, gtstep=4, incfac=23, lmat=42,& + lmax0=35, lmaxs=36, nextv=47, nreduc=6, preduc=7,& + radfac=16, radius=8, rad0=9, reldx=17, tuner4=29,& + tuner5=30 +!/ +! +!/6 +! data half/0.5d+0/, negone/-1.d+0/, one/1.d+0/, onep2/1.2d+0/, +! 1 zero/0.d+0/ +!/7 + real(kind=8),parameter :: half=0.5d+0, negone=-1.d+0, one=1.d+0,& + onep2=1.2d+0,zero=0.d+0 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! +! Following SAVE statement inserted. + save l + i = iv(1) + if (i .eq. 1) go to 50 + if (i .eq. 2) go to 60 +! +! *** check validity of iv and v input values *** +! + if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) + if (iv(1) .eq. 12 .or. iv(1) .eq. 13) & + iv(vneed) = iv(vneed) + n*(n+13)/2 + call parck(2, d, iv, liv, lv, n, v) + i = iv(1) - 2 + if (i .gt. 12) go to 999 + go to (180, 180, 180, 180, 180, 180, 120, 90, 120, 10, 10, 20), i +! +! *** storage allocation *** +! +10 l = iv(lmat) + iv(x0) = l + n*(n+1)/2 + iv(step) = iv(x0) + n + iv(stlstg) = iv(step) + n + iv(g0) = iv(stlstg) + n + iv(nwtstp) = iv(g0) + n + iv(dg) = iv(nwtstp) + n + iv(nextv) = iv(dg) + n + if (iv(1) .ne. 13) go to 20 + iv(1) = 14 + go to 999 +! +! *** initialization *** +! + 20 iv(niter) = 0 + iv(nfcall) = 1 + iv(ngcall) = 1 + iv(nfgcal) = 1 + iv(mode) = -1 + iv(model) = 1 + iv(stglim) = 1 + iv(toobig) = 0 + iv(cnvcod) = 0 + iv(radinc) = 0 + v(rad0) = zero + if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) + if (iv(inith) .ne. 1) go to 40 +! +! *** set the initial hessian approximation to diag(d)**-2 *** +! + l = iv(lmat) + call vscopy(n*(n+1)/2, v(l), zero) + k = l - 1 + do 30 i = 1, n + k = k + i + t = d(i) + if (t .le. zero) t = one + v(k) = t + 30 continue +! +! *** compute initial function value *** +! + 40 iv(1) = 1 + go to 999 +! + 50 v(f) = fx + if (iv(mode) .ge. 0) go to 180 + iv(1) = 2 + if (iv(toobig) .eq. 0) go to 999 + iv(1) = 63 + go to 300 +! +! *** make sure gradient could be computed *** +! + 60 if (iv(nfgcal) .ne. 0) go to 70 + iv(1) = 65 + go to 300 +! + 70 dg1 = iv(dg) + call vvmulp(n, v(dg1), g, d, -1) + v(dgnorm) = v2norm(n, v(dg1)) +! +! *** test norm of gradient *** +! + if (v(dgnorm) .gt. v(afctol)) go to 75 + iv(irc) = 10 + iv(cnvcod) = iv(irc) - 4 +! + 75 if (iv(cnvcod) .ne. 0) go to 290 + if (iv(mode) .eq. 0) go to 250 +! +! *** allow first step to have scaled 2-norm at most v(lmax0) *** +! + v(radius) = v(lmax0) +! + iv(mode) = 0 +! +! +!----------------------------- main loop ----------------------------- +! +! +! *** print iteration summary, check iteration limit *** +! + 80 call itsum(d, g, iv, liv, lv, n, v, x) + 90 k = iv(niter) + if (k .lt. iv(mxiter)) go to 100 + iv(1) = 10 + go to 300 +! +! *** update radius *** +! + 100 iv(niter) = k + 1 + if(k.gt.0)v(radius) = v(radfac) * v(dstnrm) +! +! *** initialize for start of next iteration *** +! + g01 = iv(g0) + x01 = iv(x0) + v(f0) = v(f) + iv(irc) = 4 + iv(kagqt) = -1 +! +! *** copy x to x0, g to g0 *** +! + call vcopy(n, v(x01), x) + call vcopy(n, v(g01), g) +! +! *** check stopx and function evaluation limit *** +! +! AL 4/30/95 + dummy=iv(nfcall) +!el lstopx = stopx(dummy) +!elwrite(iout,*) "lstopx",lstopx,dummy + 110 if (.not. stopx(dummy)) go to 130 + iv(1) = 11 +! write (iout,*) "iv(1)=11 !!!!" + go to 140 +! +! *** come here when restarting after func. eval. limit or stopx. +! + 120 if (v(f) .ge. v(f0)) go to 130 + v(radfac) = one + k = iv(niter) + go to 100 +! + 130 if (iv(nfcall) .lt. iv(mxfcal)) go to 150 + iv(1) = 9 + 140 if (v(f) .ge. v(f0)) go to 300 +! +! *** in case of stopx or function evaluation limit with +! *** improved v(f), evaluate the gradient at x. +! + iv(cnvcod) = iv(1) + go to 240 +! +!. . . . . . . . . . . . . compute candidate step . . . . . . . . . . +! + 150 step1 = iv(step) + dg1 = iv(dg) + nwtst1 = iv(nwtstp) + if (iv(kagqt) .ge. 0) go to 160 + l = iv(lmat) + call livmul(n, v(nwtst1), v(l), g) + v(nreduc) = half * dotprd(n, v(nwtst1), v(nwtst1)) + call litvmu(n, v(nwtst1), v(l), v(nwtst1)) + call vvmulp(n, v(step1), v(nwtst1), d, 1) + v(dst0) = v2norm(n, v(step1)) + call vvmulp(n, v(dg1), v(dg1), d, -1) + call ltvmul(n, v(step1), v(l), v(dg1)) + v(gthg) = v2norm(n, v(step1)) + iv(kagqt) = 0 + 160 call dbdog(v(dg1), lv, n, v(nwtst1), v(step1), v) + if (iv(irc) .eq. 6) go to 180 +! +! *** check whether evaluating f(x0 + step) looks worthwhile *** +! + if (v(dstnrm) .le. zero) go to 180 + if (iv(irc) .ne. 5) go to 170 + if (v(radfac) .le. one) go to 170 + if (v(preduc) .le. onep2 * v(fdif)) go to 180 +! +! *** compute f(x0 + step) *** +! + 170 x01 = iv(x0) + step1 = iv(step) + call vaxpy(n, x, one, v(step1), v(x01)) + iv(nfcall) = iv(nfcall) + 1 + iv(1) = 1 + iv(toobig) = 0 + go to 999 +! +!. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . +! + 180 x01 = iv(x0) + v(reldx) = reldst(n, d, x, v(x01)) + call assst(iv, liv, lv, v) + step1 = iv(step) + lstgst = iv(stlstg) + if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) + if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) + if (iv(restor) .ne. 3) go to 190 + call vcopy(n, v(step1), v(lstgst)) + call vaxpy(n, x, one, v(step1), v(x01)) + v(reldx) = reldst(n, d, x, v(x01)) +! + 190 k = iv(irc) + go to (200,230,230,230,200,210,220,220,220,220,220,220,280,250), k +! +! *** recompute step with changed radius *** +! + 200 v(radius) = v(radfac) * v(dstnrm) + go to 110 +! +! *** compute step of length v(lmaxs) for singular convergence test. +! + 210 v(radius) = v(lmaxs) + go to 150 +! +! *** convergence or false convergence *** +! + 220 iv(cnvcod) = k - 4 + if (v(f) .ge. v(f0)) go to 290 + if (iv(xirc) .eq. 14) go to 290 + iv(xirc) = 14 +! +!. . . . . . . . . . . . process acceptable step . . . . . . . . . . . +! + 230 if (iv(irc) .ne. 3) go to 240 + step1 = iv(step) + temp1 = iv(stlstg) +! +! *** set temp1 = hessian * step for use in gradient tests *** +! + l = iv(lmat) + call ltvmul(n, v(temp1), v(l), v(step1)) + call lvmul(n, v(temp1), v(l), v(temp1)) +! +! *** compute gradient *** +! + 240 iv(ngcall) = iv(ngcall) + 1 + iv(1) = 2 + go to 999 +! +! *** initializations -- g0 = g - g0, etc. *** +! + 250 g01 = iv(g0) + call vaxpy(n, v(g01), negone, v(g01), g) + step1 = iv(step) + temp1 = iv(stlstg) + if (iv(irc) .ne. 3) go to 270 +! +! *** set v(radfac) by gradient tests *** +! +! *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** +! + call vaxpy(n, v(temp1), negone, v(g01), v(temp1)) + call vvmulp(n, v(temp1), v(temp1), d, -1) +! +! *** do gradient tests *** +! + if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) & + go to 260 + if (dotprd(n, g, v(step1)) & + .ge. v(gtstep) * v(tuner5)) go to 270 + 260 v(radfac) = v(incfac) +! +! *** update h, loop *** +! + 270 w = iv(nwtstp) + z = iv(x0) + l = iv(lmat) + call wzbfgs(v(l), n, v(step1), v(w), v(g01), v(z)) +! +! ** use the n-vectors starting at v(step1) and v(g01) for scratch.. + call lupdat(v(temp1), v(step1), v(l), v(g01), v(l), n, v(w), v(z)) + iv(1) = 2 + go to 80 +! +!. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . +! +! *** bad parameters to assess *** +! + 280 iv(1) = 64 + go to 300 +! +! *** print summary of final iteration and other requested items *** +! + 290 iv(1) = iv(cnvcod) + iv(cnvcod) = 0 + 300 call itsum(d, g, iv, liv, lv, n, v, x) +! + 999 return +! +! *** last line of sumit follows *** + end subroutine sumit +!----------------------------------------------------------------------------- + subroutine dbdog(dig,lv,n,nwtstp,step,v) +! +! *** compute double dogleg step *** +! +! *** parameter declarations *** +! + integer :: lv, n + real(kind=8) :: dig(n), nwtstp(n), step(n), v(lv) +! +! *** purpose *** +! +! this subroutine computes a candidate step (for use in an uncon- +! strained minimization code) by the double dogleg algorithm of +! dennis and mei (ref. 1), which is a variation on powell*s dogleg +! scheme (ref. 2, p. 95). +! +!-------------------------- parameter usage -------------------------- +! +! dig (input) diag(d)**-2 * g -- see algorithm notes. +! g (input) the current gradient vector. +! lv (input) length of v. +! n (input) number of components in dig, g, nwtstp, and step. +! nwtstp (input) negative newton step -- see algorithm notes. +! step (output) the computed step. +! v (i/o) values array, the following components of which are +! used here... +! v(bias) (input) bias for relaxed newton step, which is v(bias) of +! the way from the full newton to the fully relaxed newton +! step. recommended value = 0.8 . +! v(dgnorm) (input) 2-norm of diag(d)**-1 * g -- see algorithm notes. +! v(dstnrm) (output) 2-norm of diag(d) * step, which is v(radius) +! unless v(stppar) = 0 -- see algorithm notes. +! v(dst0) (input) 2-norm of diag(d) * nwtstp -- see algorithm notes. +! v(grdfac) (output) the coefficient of dig in the step returned -- +! step(i) = v(grdfac)*dig(i) + v(nwtfac)*nwtstp(i). +! v(gthg) (input) square-root of (dig**t) * (hessian) * dig -- see +! algorithm notes. +! v(gtstep) (output) inner product between g and step. +! v(nreduc) (output) function reduction predicted for the full newton +! step. +! v(nwtfac) (output) the coefficient of nwtstp in the step returned -- +! see v(grdfac) above. +! v(preduc) (output) function reduction predicted for the step returned. +! v(radius) (input) the trust region radius. d times the step returned +! has 2-norm v(radius) unless v(stppar) = 0. +! v(stppar) (output) code telling how step was computed... 0 means a +! full newton step. between 0 and 1 means v(stppar) of the +! way from the newton to the relaxed newton step. between +! 1 and 2 means a true double dogleg step, v(stppar) - 1 of +! the way from the relaxed newton to the cauchy step. +! greater than 2 means 1 / (v(stppar) - 1) times the cauchy +! step. +! +!------------------------------- notes ------------------------------- +! +! *** algorithm notes *** +! +! let g and h be the current gradient and hessian approxima- +! tion respectively and let d be the current scale vector. this +! routine assumes dig = diag(d)**-2 * g and nwtstp = h**-1 * g. +! the step computed is the same one would get by replacing g and h +! by diag(d)**-1 * g and diag(d)**-1 * h * diag(d)**-1, +! computing step, and translating step back to the original +! variables, i.e., premultiplying it by diag(d)**-1. +! +! *** references *** +! +! 1. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- +! mization algorithms which use function and gradient +! values, j. optim. theory applic. 28, pp. 453-482. +! 2. powell, m.j.d. (1970), a hybrid method for non-linear equations, +! in numerical methods for non-linear equations, edited by +! p. rabinowitz, gordon and breach, london. +! +! *** general *** +! +! coded by david m. gay. +! this subroutine was written in connection with research supported +! by the national science foundation under grants mcs-7600324 and +! mcs-7906671. +! +!------------------------ external quantities ------------------------ +! +! *** functions and subroutines called *** +! +!el external dotprd, v2norm +!el real(kind=8) :: dotprd, v2norm +! +! dotprd... returns inner product of two vectors. +! v2norm... returns 2-norm of a vector. +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dsqrt +!/ +!-------------------------- local variables -------------------------- +! + integer :: i + real(kind=8) :: cfact, cnorm, ctrnwt, ghinvg, femnsq, gnorm,& + nwtnrm, relax, rlambd, t, t1, t2 +!el real(kind=8) :: half, one, two, zero +! +! *** v subscripts *** +! +!el integer bias, dgnorm, dstnrm, dst0, grdfac, gthg, gtstep, +!el 1 nreduc, nwtfac, preduc, radius, stppar +! +! *** data initializations *** +! +!/6 +! data half/0.5d+0/, one/1.d+0/, two/2.d+0/, zero/0.d+0/ +!/7 + real(kind=8),parameter :: half=0.5d+0, one=1.d+0, two=2.d+0, zero=0.d+0 +!/ +! +!/6 +! data bias/43/, dgnorm/1/, dstnrm/2/, dst0/3/, grdfac/45/, +! 1 gthg/44/, gtstep/4/, nreduc/6/, nwtfac/46/, preduc/7/, +! 2 radius/8/, stppar/5/ +!/7 + integer,parameter :: bias=43, dgnorm=1, dstnrm=2, dst0=3, grdfac=45,& + gthg=44, gtstep=4, nreduc=6, nwtfac=46, preduc=7,& + radius=8, stppar=5 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! + nwtnrm = v(dst0) + rlambd = one + if (nwtnrm .gt. zero) rlambd = v(radius) / nwtnrm + gnorm = v(dgnorm) + ghinvg = two * v(nreduc) + v(grdfac) = zero + v(nwtfac) = zero + if (rlambd .lt. one) go to 30 +! +! *** the newton step is inside the trust region *** +! + v(stppar) = zero + v(dstnrm) = nwtnrm + v(gtstep) = -ghinvg + v(preduc) = v(nreduc) + v(nwtfac) = -one + do 20 i = 1, n + 20 step(i) = -nwtstp(i) + go to 999 +! + 30 v(dstnrm) = v(radius) + cfact = (gnorm / v(gthg))**2 +! *** cauchy step = -cfact * g. + cnorm = gnorm * cfact + relax = one - v(bias) * (one - gnorm*cnorm/ghinvg) + if (rlambd .lt. relax) go to 50 +! +! *** step is between relaxed newton and full newton steps *** +! + v(stppar) = one - (rlambd - relax) / (one - relax) + t = -rlambd + v(gtstep) = t * ghinvg + v(preduc) = rlambd * (one - half*rlambd) * ghinvg + v(nwtfac) = t + do 40 i = 1, n + 40 step(i) = t * nwtstp(i) + go to 999 +! + 50 if (cnorm .lt. v(radius)) go to 70 +! +! *** the cauchy step lies outside the trust region -- +! *** step = scaled cauchy step *** +! + t = -v(radius) / gnorm + v(grdfac) = t + v(stppar) = one + cnorm / v(radius) + v(gtstep) = -v(radius) * gnorm + v(preduc) = v(radius)*(gnorm - half*v(radius)*(v(gthg)/gnorm)**2) + do 60 i = 1, n + 60 step(i) = t * dig(i) + go to 999 +! +! *** compute dogleg step between cauchy and relaxed newton *** +! *** femur = relaxed newton step minus cauchy step *** +! + 70 ctrnwt = cfact * relax * ghinvg / gnorm +! *** ctrnwt = inner prod. of cauchy and relaxed newton steps, +! *** scaled by gnorm**-1. + t1 = ctrnwt - gnorm*cfact**2 +! *** t1 = inner prod. of femur and cauchy step, scaled by +! *** gnorm**-1. + t2 = v(radius)*(v(radius)/gnorm) - gnorm*cfact**2 + t = relax * nwtnrm + femnsq = (t/gnorm)*t - ctrnwt - t1 +! *** femnsq = square of 2-norm of femur, scaled by gnorm**-1. + t = t2 / (t1 + dsqrt(t1**2 + femnsq*t2)) +! *** dogleg step = cauchy step + t * femur. + t1 = (t - one) * cfact + v(grdfac) = t1 + t2 = -t * relax + v(nwtfac) = t2 + v(stppar) = two - t + v(gtstep) = t1*gnorm**2 + t2*ghinvg + v(preduc) = -t1*gnorm * ((t2 + one)*gnorm) & + - t2 * (one + half*t2)*ghinvg & + - half * (v(gthg)*t1)**2 + do 80 i = 1, n + 80 step(i) = t1*dig(i) + t2*nwtstp(i) +! + 999 return +! *** last line of dbdog follows *** + end subroutine dbdog +!----------------------------------------------------------------------------- + subroutine ltvmul(n,x,l,y) +! +! *** compute x = (l**t)*y, where l is an n x n lower +! *** triangular matrix stored compactly by rows. x and y may +! *** occupy the same storage. *** +! + integer :: n +!al real(kind=8) :: x(n), l(1), y(n) + real(kind=8) :: x(n), l(n*(n+1)/2), y(n) +! dimension l(n*(n+1)/2) + integer :: i, ij, i0, j + real(kind=8) :: yi !el, zero +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +! + i0 = 0 + do 20 i = 1, n + yi = y(i) + x(i) = zero + do 10 j = 1, i + ij = i0 + j + x(j) = x(j) + yi*l(ij) + 10 continue + i0 = i0 + i + 20 continue + 999 return +! *** last card of ltvmul follows *** + end subroutine ltvmul +!----------------------------------------------------------------------------- + subroutine lupdat(beta,gamma,l,lambda,lplus,n,w,z) +! +! *** compute lplus = secant update of l *** +! +! *** parameter declarations *** +! + integer :: n +!al double precision beta(n), gamma(n), l(1), lambda(n), lplus(1), + real(kind=8) :: beta(n), gamma(n), l(n*(n+1)/2), lambda(n), & + lplus(n*(n+1)/2),w(n), z(n) +! dimension l(n*(n+1)/2), lplus(n*(n+1)/2) +! +!-------------------------- parameter usage -------------------------- +! +! beta = scratch vector. +! gamma = scratch vector. +! l (input) lower triangular matrix, stored rowwise. +! lambda = scratch vector. +! lplus (output) lower triangular matrix, stored rowwise, which may +! occupy the same storage as l. +! n (input) length of vector parameters and order of matrices. +! w (input, destroyed on output) right singular vector of rank 1 +! correction to l. +! z (input, destroyed on output) left singular vector of rank 1 +! correction to l. +! +!------------------------------- notes ------------------------------- +! +! *** application and usage restrictions *** +! +! this routine updates the cholesky factor l of a symmetric +! positive definite matrix to which a secant update is being +! applied -- it computes a cholesky factor lplus of +! l * (i + z*w**t) * (i + w*z**t) * l**t. it is assumed that w +! and z have been chosen so that the updated matrix is strictly +! positive definite. +! +! *** algorithm notes *** +! +! this code uses recurrence 3 of ref. 1 (with d(j) = 1 for all j) +! to compute lplus of the form l * (i + z*w**t) * q, where q +! is an orthogonal matrix that makes the result lower triangular. +! lplus may have some negative diagonal elements. +! +! *** references *** +! +! 1. goldfarb, d. (1976), factorized variable metric methods for uncon- +! strained optimization, math. comput. 30, pp. 796-811. +! +! *** general *** +! +! coded by david m. gay (fall 1979). +! this subroutine was written in connection with research supported +! by the national science foundation under grants mcs-7600324 and +! mcs-7906671. +! +!------------------------ external quantities ------------------------ +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dsqrt +!/ +!-------------------------- local variables -------------------------- +! + integer :: i, ij, j, jj, jp1, k, nm1, np1 + real(kind=8) :: a, b, bj, eta, gj, lj, lij, ljj, nu, s, theta,& + wj, zj +!el real(kind=8) :: one, zero +! +! *** data initializations *** +! +!/6 +! data one/1.d+0/, zero/0.d+0/ +!/7 + real(kind=8),parameter :: one=1.d+0, zero=0.d+0 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! + nu = one + eta = zero + if (n .le. 1) go to 30 + nm1 = n - 1 +! +! *** temporarily store s(j) = sum over k = j+1 to n of w(k)**2 in +! *** lambda(j). +! + s = zero + do 10 i = 1, nm1 + j = n - i + s = s + w(j+1)**2 + lambda(j) = s + 10 continue +! +! *** compute lambda, gamma, and beta by goldfarb*s recurrence 3. +! + do 20 j = 1, nm1 + wj = w(j) + a = nu*z(j) - eta*wj + theta = one + a*wj + s = a*lambda(j) + lj = dsqrt(theta**2 + a*s) + if (theta .gt. zero) lj = -lj + lambda(j) = lj + b = theta*wj + s + gamma(j) = b * nu / lj + beta(j) = (a - b*eta) / lj + nu = -nu / lj + eta = -(eta + (a**2)/(theta - lj)) / lj + 20 continue + 30 lambda(n) = one + (nu*z(n) - eta*w(n))*w(n) +! +! *** update l, gradually overwriting w and z with l*w and l*z. +! + np1 = n + 1 + jj = n * (n + 1) / 2 + do 60 k = 1, n + j = np1 - k + lj = lambda(j) + ljj = l(jj) + lplus(jj) = lj * ljj + wj = w(j) + w(j) = ljj * wj + zj = z(j) + z(j) = ljj * zj + if (k .eq. 1) go to 50 + bj = beta(j) + gj = gamma(j) + ij = jj + j + jp1 = j + 1 + do 40 i = jp1, n + lij = l(ij) + lplus(ij) = lj*lij + bj*w(i) + gj*z(i) + w(i) = w(i) + lij*wj + z(i) = z(i) + lij*zj + ij = ij + i + 40 continue + 50 jj = jj - j + 60 continue +! + 999 return +! *** last card of lupdat follows *** + end subroutine lupdat +!----------------------------------------------------------------------------- + subroutine lvmul(n,x,l,y) +! +! *** compute x = l*y, where l is an n x n lower triangular +! *** matrix stored compactly by rows. x and y may occupy the same +! *** storage. *** +! + integer :: n +!al double precision x(n), l(1), y(n) + real(kind=8) :: x(n), l(n*(n+1)/2), y(n) +! dimension l(n*(n+1)/2) + integer :: i, ii, ij, i0, j, np1 + real(kind=8) :: t !el, zero +!/6 +! data zero/0.d+0/ +!/7 + real(kind=8),parameter :: zero=0.d+0 +!/ +! + np1 = n + 1 + i0 = n*(n+1)/2 + do 20 ii = 1, n + i = np1 - ii + i0 = i0 - i + t = zero + do 10 j = 1, i + ij = i0 + j + t = t + l(ij)*y(j) + 10 continue + x(i) = t + 20 continue + 999 return +! *** last card of lvmul follows *** + end subroutine lvmul +!----------------------------------------------------------------------------- + subroutine vvmulp(n,x,y,z,k) +! +! *** set x(i) = y(i) * z(i)**k, 1 .le. i .le. n (for k = 1 or -1) *** +! + integer :: n, k + real(kind=8) :: x(n), y(n), z(n) + integer :: i +! + if (k .ge. 0) go to 20 + do 10 i = 1, n + 10 x(i) = y(i) / z(i) + go to 999 +! + 20 do 30 i = 1, n + 30 x(i) = y(i) * z(i) + 999 return +! *** last card of vvmulp follows *** + end subroutine vvmulp +!----------------------------------------------------------------------------- + subroutine wzbfgs(l,n,s,w,y,z) +! +! *** compute y and z for lupdat corresponding to bfgs update. +! + integer :: n +!al double precision l(1), s(n), w(n), y(n), z(n) + real(kind=8) :: l(n*(n+1)/2), s(n), w(n), y(n), z(n) +! dimension l(n*(n+1)/2) +! +!-------------------------- parameter usage -------------------------- +! +! l (i/o) cholesky factor of hessian, a lower triang. matrix stored +! compactly by rows. +! n (input) order of l and length of s, w, y, z. +! s (input) the step just taken. +! w (output) right singular vector of rank 1 correction to l. +! y (input) change in gradients corresponding to s. +! z (output) left singular vector of rank 1 correction to l. +! +!------------------------------- notes ------------------------------- +! +! *** algorithm notes *** +! +! when s is computed in certain ways, e.g. by gqtstp or +! dbldog, it is possible to save n**2/2 operations since (l**t)*s +! or l*(l**t)*s is then known. +! if the bfgs update to l*(l**t) would reduce its determinant to +! less than eps times its old value, then this routine in effect +! replaces y by theta*y + (1 - theta)*l*(l**t)*s, where theta +! (between 0 and 1) is chosen to make the reduction factor = eps. +! +! *** general *** +! +! coded by david m. gay (fall 1979). +! this subroutine was written in connection with research supported +! by the national science foundation under grants mcs-7600324 and +! mcs-7906671. +! +!------------------------ external quantities ------------------------ +! +! *** functions and subroutines called *** +! +!el external dotprd, livmul, ltvmul +!el real(kind=8) :: dotprd +! dotprd returns inner product of two vectors. +! livmul multiplies l**-1 times a vector. +! ltvmul multiplies l**t times a vector. +! +! *** intrinsic functions *** +!/+ +!el real(kind=8) :: dsqrt +!/ +!-------------------------- local variables -------------------------- +! + integer :: i + real(kind=8) :: cs, cy, epsrt, shs, ys, theta !el, eps, one +! +! *** data initializations *** +! +!/6 +! data eps/0.1d+0/, one/1.d+0/ +!/7 + real(kind=8),parameter :: eps=0.1d+0, one=1.d+0 +!/ +! +!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ +! + call ltvmul(n, w, l, s) + shs = dotprd(n, w, w) + ys = dotprd(n, y, s) + if (ys .ge. eps*shs) go to 10 + theta = (one - eps) * shs / (shs - ys) + epsrt = dsqrt(eps) + cy = theta / (shs * epsrt) + cs = (one + (theta-one)/epsrt) / shs + go to 20 + 10 cy = one / (dsqrt(ys) * dsqrt(shs)) + cs = one / shs + 20 call livmul(n, z, l, y) + do 30 i = 1, n + 30 z(i) = cy * z(i) - cs * w(i) +! + 999 return +! *** last card of wzbfgs follows *** + end subroutine wzbfgs +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module minimm diff --git a/source/unres/minim.f90 b/source/unres/minim.f90 deleted file mode 100644 index 4305640..0000000 --- a/source/unres/minim.f90 +++ /dev/null @@ -1,6508 +0,0 @@ - module minimm -!----------------------------------------------------------------------------- - use io_units - use names - use math -! use MPI_data - use geometry_data - use energy_data - use control_data - use minim_data - use geometry -! use csa_data -! use energy - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! cored.f -!----------------------------------------------------------------------------- - subroutine assst(iv, liv, lv, v) -! -! *** assess candidate step (***sol version 2.3) *** -! - integer :: liv, l,lv - integer :: iv(liv) - real(kind=8) :: v(lv) -! -! *** purpose *** -! -! this subroutine is called by an unconstrained minimization -! routine to assess the next candidate step. it may recommend one -! of several courses of action, such as accepting the step, recom- -! puting it using the same or a new quadratic model, or halting due -! to convergence or false convergence. see the return code listing -! below. -! -!-------------------------- parameter usage -------------------------- -! -! iv (i/o) integer parameter and scratch vector -- see description -! below of iv values referenced. -! liv (in) length of iv array. -! lv (in) length of v array. -! v (i/o) real parameter and scratch vector -- see description -! below of v values referenced. -! -! *** iv values referenced *** -! -! iv(irc) (i/o) on input for the first step tried in a new iteration, -! iv(irc) should be set to 3 or 4 (the value to which it is -! set when step is definitely to be accepted). on input -! after step has been recomputed, iv(irc) should be -! unchanged since the previous return of assst. -! on output, iv(irc) is a return code having one of the -! following values... -! 1 = switch models or try smaller step. -! 2 = switch models or accept step. -! 3 = accept step and determine v(radfac) by gradient -! tests. -! 4 = accept step, v(radfac) has been determined. -! 5 = recompute step (using the same model). -! 6 = recompute step with radius = v(lmaxs) but do not -! evaulate the objective function. -! 7 = x-convergence (see v(xctol)). -! 8 = relative function convergence (see v(rfctol)). -! 9 = both x- and relative function convergence. -! 10 = absolute function convergence (see v(afctol)). -! 11 = singular convergence (see v(lmaxs)). -! 12 = false convergence (see v(xftol)). -! 13 = iv(irc) was out of range on input. -! return code i has precdence over i+1 for i = 9, 10, 11. -! iv(mlstgd) (i/o) saved value of iv(model). -! iv(model) (i/o) on input, iv(model) should be an integer identifying -! the current quadratic model of the objective function. -! if a previous step yielded a better function reduction, -! then iv(model) will be set to iv(mlstgd) on output. -! iv(nfcall) (in) invocation count for the objective function. -! iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest -! function reduction this iteration. iv(nfgcal) remains -! unchanged until a function reduction is obtained. -! iv(radinc) (i/o) the number of radius increases (or minus the number -! of decreases) so far this iteration. -! iv(restor) (out) set to 1 if v(f) has been restored and x should be -! restored to its initial value, to 2 if x should be saved, -! to 3 if x should be restored from the saved value, and to -! 0 otherwise. -! iv(stage) (i/o) count of the number of models tried so far in the -! current iteration. -! iv(stglim) (in) maximum number of models to consider. -! iv(switch) (out) set to 0 unless a new model is being tried and it -! gives a smaller function value than the previous model, -! in which case assst sets iv(switch) = 1. -! iv(toobig) (in) is nonzero if step was too big (e.g. if it caused -! overflow). -! iv(xirc) (i/o) value that iv(irc) would have in the absence of -! convergence, false convergence, and oversized steps. -! -! *** v values referenced *** -! -! v(afctol) (in) absolute function convergence tolerance. if the -! absolute value of the current function value v(f) is less -! than v(afctol), then assst returns with iv(irc) = 10. -! v(decfac) (in) factor by which to decrease radius when iv(toobig) is -! nonzero. -! v(dstnrm) (in) the 2-norm of d*step. -! v(dstsav) (i/o) value of v(dstnrm) on saved step. -! v(dst0) (in) the 2-norm of d times the newton step (when defined, -! i.e., for v(nreduc) .ge. 0). -! v(f) (i/o) on both input and output, v(f) is the objective func- -! tion value at x. if x is restored to a previous value, -! then v(f) is restored to the corresponding value. -! v(fdif) (out) the function reduction v(f0) - v(f) (for the output -! value of v(f) if an earlier step gave a bigger function -! decrease, and for the input value of v(f) otherwise). -! v(flstgd) (i/o) saved value of v(f). -! v(f0) (in) objective function value at start of iteration. -! v(gtslst) (i/o) value of v(gtstep) on saved step. -! v(gtstep) (in) inner product between step and gradient. -! v(incfac) (in) minimum factor by which to increase radius. -! v(lmaxs) (in) maximum reasonable step size (and initial step bound). -! if the actual function decrease is no more than twice -! what was predicted, if a return with iv(irc) = 7, 8, 9, -! or 10 does not occur, if v(dstnrm) .gt. v(lmaxs), and if -! v(preduc) .le. v(sctol) * abs(v(f0)), then assst re- -! turns with iv(irc) = 11. if so doing appears worthwhile, -! then assst repeats this test with v(preduc) computed for -! a step of length v(lmaxs) (by a return with iv(irc) = 6). -! v(nreduc) (i/o) function reduction predicted by quadratic model for -! newton step. if assst is called with iv(irc) = 6, i.e., -! if v(preduc) has been computed with radius = v(lmaxs) for -! use in the singular convervence test, then v(nreduc) is -! set to -v(preduc) before the latter is restored. -! v(plstgd) (i/o) value of v(preduc) on saved step. -! v(preduc) (i/o) function reduction predicted by quadratic model for -! current step. -! v(radfac) (out) factor to be used in determining the new radius, -! which should be v(radfac)*dst, where dst is either the -! output value of v(dstnrm) or the 2-norm of -! diag(newd)*step for the output value of step and the -! updated version, newd, of the scale vector d. for -! iv(irc) = 3, v(radfac) = 1.0 is returned. -! v(rdfcmn) (in) minimum value for v(radfac) in terms of the input -! value of v(dstnrm) -- suggested value = 0.1. -! v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0. -! v(reldx) (in) scaled relative change in x caused by step, computed -! (e.g.) by function reldst as -! max (d(i)*abs(x(i)-x0(i)), 1 .le. i .le. p) / -! max (d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p). -! v(rfctol) (in) relative function convergence tolerance. if the -! actual function reduction is at most twice what was pre- -! dicted and v(nreduc) .le. v(rfctol)*abs(v(f0)), then -! assst returns with iv(irc) = 8 or 9. -! v(stppar) (in) marquardt parameter -- 0 means full newton step. -! v(tuner1) (in) tuning constant used to decide if the function -! reduction was much less than expected. suggested -! value = 0.1. -! v(tuner2) (in) tuning constant used to decide if the function -! reduction was large enough to accept step. suggested -! value = 10**-4. -! v(tuner3) (in) tuning constant used to decide if the radius -! should be increased. suggested value = 0.75. -! v(xctol) (in) x-convergence criterion. if step is a newton step -! (v(stppar) = 0) having v(reldx) .le. v(xctol) and giving -! at most twice the predicted function decrease, then -! assst returns iv(irc) = 7 or 9. -! v(xftol) (in) false convergence tolerance. if step gave no or only -! a small function decrease and v(reldx) .le. v(xftol), -! then assst returns with iv(irc) = 12. -! -!------------------------------- notes ------------------------------- -! -! *** application and usage restrictions *** -! -! this routine is called as part of the nl2sol (nonlinear -! least-squares) package. it may be used in any unconstrained -! minimization solver that uses dogleg, goldfeld-quandt-trotter, -! or levenberg-marquardt steps. -! -! *** algorithm notes *** -! -! see (1) for further discussion of the assessing and model -! switching strategies. while nl2sol considers only two models, -! assst is designed to handle any number of models. -! -! *** usage notes *** -! -! on the first call of an iteration, only the i/o variables -! step, x, iv(irc), iv(model), v(f), v(dstnrm), v(gtstep), and -! v(preduc) need have been initialized. between calls, no i/o -! values execpt step, x, iv(model), v(f) and the stopping toler- -! ances should be changed. -! after a return for convergence or false convergence, one can -! change the stopping tolerances and call assst again, in which -! case the stopping tests will be repeated. -! -! *** references *** -! -! (1) dennis, j.e., jr., gay, d.m., and welsch, r.e. (1981), -! an adaptive nonlinear least-squares algorithm, -! acm trans. math. software, vol. 7, no. 3. -! -! (2) powell, m.j.d. (1970) a fortran subroutine for solving -! systems of nonlinear algebraic equations, in numerical -! methods for nonlinear algebraic equations, edited by -! p. rabinowitz, gordon and breach, london. -! -! *** history *** -! -! john dennis designed much of this routine, starting with -! ideas in (2). roy welsch suggested the model switching strategy. -! david gay and stephen peters cast this subroutine into a more -! portable form (winter 1977), and david gay cast it into its -! present form (fall 1978). -! -! *** general *** -! -! this subroutine was written in connection with research -! supported by the national science foundation under grants -! mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -! mcs-7906671. -! -!------------------------ external quantities ------------------------ -! -! *** no external functions and subroutines *** -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dabs, dmax1 -!/ -! *** no common blocks *** -! -!-------------------------- local variables -------------------------- -! - logical :: goodx - integer :: i, nfc - real(kind=8) :: emax, emaxs, gts, rfac1, xmax -!el real(kind=8) :: half, one, onep2, two, zero -! -! *** subscripts for iv and v *** -! -!el integer :: afctol, decfac, dstnrm, dstsav, dst0, f, fdif, flstgd, f0,& -!el gtslst, gtstep, incfac, irc, lmaxs, mlstgd, model, nfcall,& -!el nfgcal, nreduc, plstgd, preduc, radfac, radinc, rdfcmn,& -!el rdfcmx, reldx, restor, rfctol, sctol, stage, stglim,& -!el stppar, switch, toobig, tuner1, tuner2, tuner3, xctol,& -!el xftol, xirc -! -! -! *** data initializations *** -! -!/6 -! data half/0.5d+0/, one/1.d+0/, onep2/1.2d+0/, two/2.d+0/, -! 1 zero/0.d+0/ -!/7 - real(kind=8),parameter :: half=0.5d+0, one=1.d+0, onep2=1.2d+0, two=2.d+0,& - zero=0.d+0 -!/ -! -!/6 -! data irc/29/, mlstgd/32/, model/5/, nfcall/6/, nfgcal/7/, -! 1 radinc/8/, restor/9/, stage/10/, stglim/11/, switch/12/, -! 2 toobig/2/, xirc/13/ -!/7 - integer,parameter :: irc=29, mlstgd=32, model=5, nfcall=6, nfgcal=7,& - radinc=8, restor=9, stage=10, stglim=11, switch=12,& - toobig=2, xirc=13 -!/ -!/6 -! data afctol/31/, decfac/22/, dstnrm/2/, dst0/3/, dstsav/18/, -! 1 f/10/, fdif/11/, flstgd/12/, f0/13/, gtslst/14/, gtstep/4/, -! 2 incfac/23/, lmaxs/36/, nreduc/6/, plstgd/15/, preduc/7/, -! 3 radfac/16/, rdfcmn/24/, rdfcmx/25/, reldx/17/, rfctol/32/, -! 4 sctol/37/, stppar/5/, tuner1/26/, tuner2/27/, tuner3/28/, -! 5 xctol/33/, xftol/34/ -!/7 - integer,parameter :: afctol=31, decfac=22, dstnrm=2, dst0=3, dstsav=18,& - f=10, fdif=11, flstgd=12, f0=13, gtslst=14, gtstep=4,& - incfac=23, lmaxs=36, nreduc=6, plstgd=15, preduc=7,& - radfac=16, rdfcmn=24, rdfcmx=25, reldx=17, rfctol=32,& - sctol=37, stppar=5, tuner1=26, tuner2=27, tuner3=28,& - xctol=33, xftol=34 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! - nfc = iv(nfcall) - iv(switch) = 0 - iv(restor) = 0 - rfac1 = one - goodx = .true. - i = iv(irc) - if (i .ge. 1 .and. i .le. 12) & - go to (20,30,10,10,40,280,220,220,220,220,220,170), i - iv(irc) = 13 - go to 999 -! -! *** initialize for new iteration *** -! - 10 iv(stage) = 1 - iv(radinc) = 0 - v(flstgd) = v(f0) - if (iv(toobig) .eq. 0) go to 110 - iv(stage) = -1 - iv(xirc) = i - go to 60 -! -! *** step was recomputed with new model or smaller radius *** -! *** first decide which *** -! - 20 if (iv(model) .ne. iv(mlstgd)) go to 30 -! *** old model retained, smaller radius tried *** -! *** do not consider any more new models this iteration *** - iv(stage) = iv(stglim) - iv(radinc) = -1 - go to 110 -! -! *** a new model is being tried. decide whether to keep it. *** -! - 30 iv(stage) = iv(stage) + 1 -! -! *** now we add the possibiltiy that step was recomputed with *** -! *** the same model, perhaps because of an oversized step. *** -! - 40 if (iv(stage) .gt. 0) go to 50 -! -! *** step was recomputed because it was too big. *** -! - if (iv(toobig) .ne. 0) go to 60 -! -! *** restore iv(stage) and pick up where we left off. *** -! - iv(stage) = -iv(stage) - i = iv(xirc) - go to (20, 30, 110, 110, 70), i -! - 50 if (iv(toobig) .eq. 0) go to 70 -! -! *** handle oversize step *** -! - if (iv(radinc) .gt. 0) go to 80 - iv(stage) = -iv(stage) - iv(xirc) = iv(irc) -! - 60 v(radfac) = v(decfac) - iv(radinc) = iv(radinc) - 1 - iv(irc) = 5 - iv(restor) = 1 - go to 999 -! - 70 if (v(f) .lt. v(flstgd)) go to 110 -! -! *** the new step is a loser. restore old model. *** -! - if (iv(model) .eq. iv(mlstgd)) go to 80 - iv(model) = iv(mlstgd) - iv(switch) = 1 -! -! *** restore step, etc. only if a previous step decreased v(f). -! - 80 if (v(flstgd) .ge. v(f0)) go to 110 - iv(restor) = 1 - v(f) = v(flstgd) - v(preduc) = v(plstgd) - v(gtstep) = v(gtslst) - if (iv(switch) .eq. 0) rfac1 = v(dstnrm) / v(dstsav) - v(dstnrm) = v(dstsav) - nfc = iv(nfgcal) - goodx = .false. -! - 110 v(fdif) = v(f0) - v(f) - if (v(fdif) .gt. v(tuner2) * v(preduc)) go to 140 - if(iv(radinc).gt.0) go to 140 -! -! *** no (or only a trivial) function decrease -! *** -- so try new model or smaller radius -! - if (v(f) .lt. v(f0)) go to 120 - iv(mlstgd) = iv(model) - v(flstgd) = v(f) - v(f) = v(f0) - iv(restor) = 1 - go to 130 - 120 iv(nfgcal) = nfc - 130 iv(irc) = 1 - if (iv(stage) .lt. iv(stglim)) go to 160 - iv(irc) = 5 - iv(radinc) = iv(radinc) - 1 - go to 160 -! -! *** nontrivial function decrease achieved *** -! - 140 iv(nfgcal) = nfc - rfac1 = one - v(dstsav) = v(dstnrm) - if (v(fdif) .gt. v(preduc)*v(tuner1)) go to 190 -! -! *** decrease was much less than predicted -- either change models -! *** or accept step with decreased radius. -! - if (iv(stage) .ge. iv(stglim)) go to 150 -! *** consider switching models *** - iv(irc) = 2 - go to 160 -! -! *** accept step with decreased radius *** -! - 150 iv(irc) = 4 -! -! *** set v(radfac) to fletcher*s decrease factor *** -! - 160 iv(xirc) = iv(irc) - emax = v(gtstep) + v(fdif) - v(radfac) = half * rfac1 - if (emax .lt. v(gtstep)) v(radfac) = rfac1 * dmax1(v(rdfcmn),& - half * v(gtstep)/emax) -! -! *** do false convergence test *** -! - 170 if (v(reldx) .le. v(xftol)) go to 180 - iv(irc) = iv(xirc) - if (v(f) .lt. v(f0)) go to 200 - go to 230 -! - 180 iv(irc) = 12 - go to 240 -! -! *** handle good function decrease *** -! - 190 if (v(fdif) .lt. (-v(tuner3) * v(gtstep))) go to 210 -! -! *** increasing radius looks worthwhile. see if we just -! *** recomputed step with a decreased radius or restored step -! *** after recomputing it with a larger radius. -! - if (iv(radinc) .lt. 0) go to 210 - if (iv(restor) .eq. 1) go to 210 -! -! *** we did not. try a longer step unless this was a newton -! *** step. - - v(radfac) = v(rdfcmx) - gts = v(gtstep) - if (v(fdif) .lt. (half/v(radfac) - one) * gts) & - v(radfac) = dmax1(v(incfac), half*gts/(gts + v(fdif))) - iv(irc) = 4 - if (v(stppar) .eq. zero) go to 230 - if (v(dst0) .ge. zero .and. (v(dst0) .lt. two*v(dstnrm) & - .or. v(nreduc) .lt. onep2*v(fdif))) go to 230 -! *** step was not a newton step. recompute it with -! *** a larger radius. - iv(irc) = 5 - iv(radinc) = iv(radinc) + 1 -! -! *** save values corresponding to good step *** -! - 200 v(flstgd) = v(f) - iv(mlstgd) = iv(model) - if (iv(restor) .ne. 1) iv(restor) = 2 - v(dstsav) = v(dstnrm) - iv(nfgcal) = nfc - v(plstgd) = v(preduc) - v(gtslst) = v(gtstep) - go to 230 -! -! *** accept step with radius unchanged *** -! - 210 v(radfac) = one - iv(irc) = 3 - go to 230 -! -! *** come here for a restart after convergence *** -! - 220 iv(irc) = iv(xirc) - if (v(dstsav) .ge. zero) go to 240 - iv(irc) = 12 - go to 240 -! -! *** perform convergence tests *** -! - 230 iv(xirc) = iv(irc) - 240 if (iv(restor) .eq. 1 .and. v(flstgd) .lt. v(f0)) iv(restor) = 3 - if (half * v(fdif) .gt. v(preduc)) go to 999 - emax = v(rfctol) * dabs(v(f0)) - emaxs = v(sctol) * dabs(v(f0)) - if (v(dstnrm) .gt. v(lmaxs) .and. v(preduc) .le. emaxs) & - iv(irc) = 11 - if (v(dst0) .lt. zero) go to 250 - i = 0 - if ((v(nreduc) .gt. zero .and. v(nreduc) .le. emax) .or. & - (v(nreduc) .eq. zero .and. v(preduc) .eq. zero)) i = 2 - if (v(stppar) .eq. zero .and. v(reldx) .le. v(xctol) & - .and. goodx) i = i + 1 - if (i .gt. 0) iv(irc) = i + 6 -! -! *** consider recomputing step of length v(lmaxs) for singular -! *** convergence test. -! - 250 if (iv(irc) .gt. 5 .and. iv(irc) .ne. 12) go to 999 - if (v(dstnrm) .gt. v(lmaxs)) go to 260 - if (v(preduc) .ge. emaxs) go to 999 - if (v(dst0) .le. zero) go to 270 - if (half * v(dst0) .le. v(lmaxs)) go to 999 - go to 270 - 260 if (half * v(dstnrm) .le. v(lmaxs)) go to 999 - xmax = v(lmaxs) / v(dstnrm) - if (xmax * (two - xmax) * v(preduc) .ge. emaxs) go to 999 - 270 if (v(nreduc) .lt. zero) go to 290 -! -! *** recompute v(preduc) for use in singular convergence test *** -! - v(gtslst) = v(gtstep) - v(dstsav) = v(dstnrm) - if (iv(irc) .eq. 12) v(dstsav) = -v(dstsav) - v(plstgd) = v(preduc) - i = iv(restor) - iv(restor) = 2 - if (i .eq. 3) iv(restor) = 0 - iv(irc) = 6 - go to 999 -! -! *** perform singular convergence test with recomputed v(preduc) *** -! - 280 v(gtstep) = v(gtslst) - v(dstnrm) = dabs(v(dstsav)) - iv(irc) = iv(xirc) - if (v(dstsav) .le. zero) iv(irc) = 12 - v(nreduc) = -v(preduc) - v(preduc) = v(plstgd) - iv(restor) = 3 - 290 if (-v(nreduc) .le. v(sctol) * dabs(v(f0))) iv(irc) = 11 -! - 999 return -! -! *** last card of assst follows *** - end subroutine assst -!----------------------------------------------------------------------------- - subroutine deflt(alg, iv, liv, lv, v) -! -! *** supply ***sol (version 2.3) default values to iv and v *** -! -! *** alg = 1 means regression constants. -! *** alg = 2 means general unconstrained optimization constants. -! - integer :: liv, l,lv - integer :: alg, iv(liv) - real(kind=8) :: v(lv) -! -!el external imdcon, vdflt -!el integer imdcon -! imdcon... returns machine-dependent integer constants. -! vdflt.... provides default values to v. -! - integer :: miv, m - integer :: miniv(2), minv(2) -! -! *** subscripts for iv *** -! -!el integer algsav, covprt, covreq, dtype, hc, ierr, inith, inits, -!el 1 ipivot, ivneed, lastiv, lastv, lmat, mxfcal, mxiter, -!el 2 nfcov, ngcov, nvdflt, outlev, parprt, parsav, perm, -!el 3 prunit, qrtyp, rdreq, rmat, solprt, statpr, vneed, -!el 4 vsave, x0prt -! -! *** iv subscript values *** -! -!/6 -! data algsav/51/, covprt/14/, covreq/15/, dtype/16/, hc/71/, -! 1 ierr/75/, inith/25/, inits/25/, ipivot/76/, ivneed/3/, -! 2 lastiv/44/, lastv/45/, lmat/42/, mxfcal/17/, mxiter/18/, -! 3 nfcov/52/, ngcov/53/, nvdflt/50/, outlev/19/, parprt/20/, -! 4 parsav/49/, perm/58/, prunit/21/, qrtyp/80/, rdreq/57/, -! 5 rmat/78/, solprt/22/, statpr/23/, vneed/4/, vsave/60/, -! 6 x0prt/24/ -!/7 - integer,parameter :: algsav=51, covprt=14, covreq=15, dtype=16, hc=71,& - ierr=75, inith=25, inits=25, ipivot=76, ivneed=3,& - lastiv=44, lastv=45, lmat=42, mxfcal=17, mxiter=18,& - nfcov=52, ngcov=53, nvdflt=50, outlev=19, parprt=20,& - parsav=49, perm=58, prunit=21, qrtyp=80, rdreq=57,& - rmat=78, solprt=22, statpr=23, vneed=4, vsave=60,& - x0prt=24 -!/ - data miniv(1)/80/, miniv(2)/59/, minv(1)/98/, minv(2)/71/ -!el local variables - integer :: mv -! -!------------------------------- body -------------------------------- -! - if (alg .lt. 1 .or. alg .gt. 2) go to 40 - miv = miniv(alg) - if (liv .lt. miv) go to 20 - mv = minv(alg) - if (lv .lt. mv) go to 30 - call vdflt(alg, lv, v) - iv(1) = 12 - iv(algsav) = alg - iv(ivneed) = 0 - iv(lastiv) = miv - iv(lastv) = mv - iv(lmat) = mv + 1 - iv(mxfcal) = 200 - iv(mxiter) = 150 - iv(outlev) = 1 - iv(parprt) = 1 - iv(perm) = miv + 1 - iv(prunit) = imdcon(1) - iv(solprt) = 1 - iv(statpr) = 1 - iv(vneed) = 0 - iv(x0prt) = 1 -! - if (alg .ge. 2) go to 10 -! -! *** regression values -! - iv(covprt) = 3 - iv(covreq) = 1 - iv(dtype) = 1 - iv(hc) = 0 - iv(ierr) = 0 - iv(inits) = 0 - iv(ipivot) = 0 - iv(nvdflt) = 32 - iv(parsav) = 67 - iv(qrtyp) = 1 - iv(rdreq) = 3 - iv(rmat) = 0 - iv(vsave) = 58 - go to 999 -! -! *** general optimization values -! - 10 iv(dtype) = 0 - iv(inith) = 1 - iv(nfcov) = 0 - iv(ngcov) = 0 - iv(nvdflt) = 25 - iv(parsav) = 47 - go to 999 -! - 20 iv(1) = 15 - go to 999 -! - 30 iv(1) = 16 - go to 999 -! - 40 iv(1) = 67 -! - 999 return -! *** last card of deflt follows *** - end subroutine deflt -!----------------------------------------------------------------------------- - real(kind=8) function dotprd(p,x,y) -! -! *** return the inner product of the p-vectors x and y. *** -! - integer :: p - real(kind=8) :: x(p), y(p) -! - integer :: i -!el real(kind=8) :: one, zero - real(kind=8) :: sqteta, t -!/+ -!el real(kind=8) :: dmax1, dabs -!/ -!el external rmdcon -!el real(kind=8) :: rmdcon -! -! *** rmdcon(2) returns a machine-dependent constant, sqteta, which -! *** is slightly larger than the smallest positive number that -! *** can be squared without underflowing. -! -!/6 -! data one/1.d+0/, sqteta/0.d+0/, zero/0.d+0/ -!/7 - real(kind=8),parameter :: one=1.d+0, zero=0.d+0 - data sqteta/0.d+0/ -!/ -! - dotprd = zero - if (p .le. 0) go to 999 -!rc if (sqteta .eq. zero) sqteta = rmdcon(2) - do 20 i = 1, p -!rc t = dmax1(dabs(x(i)), dabs(y(i))) -!rc if (t .gt. one) go to 10 -!rc if (t .lt. sqteta) go to 20 -!rc t = (x(i)/sqteta)*y(i) -!rc if (dabs(t) .lt. sqteta) go to 20 - 10 dotprd = dotprd + x(i)*y(i) - 20 continue -! - 999 return -! *** last card of dotprd follows *** - end function dotprd -!----------------------------------------------------------------------------- - subroutine itsum(d, g, iv, liv, lv, p, v, x) -! -! *** print iteration summary for ***sol (version 2.3) *** -! -! *** parameter declarations *** -! - integer :: liv, lv, p - integer :: iv(liv) - real(kind=8) :: d(p), g(p), v(lv), x(p) -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -! *** local variables *** -! - integer :: alg, i, iv1, m, nf, ng, ol, pu -!/6 -! real model1(6), model2(6) -!/7 - character(len=4) :: model1(6), model2(6) -!/ - real(kind=8) :: nreldf, oldf, preldf, reldf !el, zero -! -! *** intrinsic functions *** -!/+ -!el integer :: iabs -!el real(kind=8) :: dabs, dmax1 -!/ -! *** no external functions or subroutines *** -! -! *** subscripts for iv and v *** -! -!el integer algsav, dstnrm, f, fdif, f0, needhd, nfcall, nfcov, ngcov, -!el 1 ngcall, niter, nreduc, outlev, preduc, prntit, prunit, -!el 2 reldx, solprt, statpr, stppar, sused, x0prt -! -! *** iv subscript values *** -! -!/6 -! data algsav/51/, needhd/36/, nfcall/6/, nfcov/52/, ngcall/30/, -! 1 ngcov/53/, niter/31/, outlev/19/, prntit/39/, prunit/21/, -! 2 solprt/22/, statpr/23/, sused/64/, x0prt/24/ -!/7 - integer,parameter :: algsav=51, needhd=36, nfcall=6, nfcov=52, ngcall=30,& - ngcov=53, niter=31, outlev=19, prntit=39, prunit=21,& - solprt=22, statpr=23, sused=64, x0prt=24 -!/ -! -! *** v subscript values *** -! -!/6 -! data dstnrm/2/, f/10/, f0/13/, fdif/11/, nreduc/6/, preduc/7/, -! 1 reldx/17/, stppar/5/ -!/7 - integer,parameter :: dstnrm=2, f=10, f0=13, fdif=11, nreduc=6, preduc=7,& - reldx=17, stppar=5 -!/ -! -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -!/6 -! data model1(1)/4h /, model1(2)/4h /, model1(3)/4h /, -! 1 model1(4)/4h /, model1(5)/4h g /, model1(6)/4h s /, -! 2 model2(1)/4h g /, model2(2)/4h s /, model2(3)/4hg-s /, -! 3 model2(4)/4hs-g /, model2(5)/4h-s-g/, model2(6)/4h-g-s/ -!/7 - data model1/' ',' ',' ',' ',' g ',' s '/,& - model2/' g ',' s ','g-s ','s-g ','-s-g','-g-s'/ -!/ -! -!------------------------------- body -------------------------------- -! - pu = iv(prunit) - if (pu .eq. 0) go to 999 - iv1 = iv(1) - if (iv1 .gt. 62) iv1 = iv1 - 51 - ol = iv(outlev) - alg = iv(algsav) - if (iv1 .lt. 2 .or. iv1 .gt. 15) go to 370 - if (iv1 .ge. 12) go to 120 - if (iv1 .eq. 2 .and. iv(niter) .eq. 0) go to 390 - if (ol .eq. 0) go to 120 - if (iv1 .ge. 10 .and. iv(prntit) .eq. 0) go to 120 - if (iv1 .gt. 2) go to 10 - iv(prntit) = iv(prntit) + 1 - if (iv(prntit) .lt. iabs(ol)) go to 999 - 10 nf = iv(nfcall) - iabs(iv(nfcov)) - iv(prntit) = 0 - reldf = zero - preldf = zero - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - if (oldf .le. zero) go to 20 - reldf = v(fdif) / oldf - preldf = v(preduc) / oldf - 20 if (ol .gt. 0) go to 60 -! -! *** print short summary line *** -! - if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,30) - 30 format(/10h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx,& - 2x,13hmodel stppar) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,40) - 40 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx,& - 3x,6hstppar) - iv(needhd) = 0 - if (alg .eq. 2) go to 50 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx),& - model1(m), model2(m), v(stppar) - go to 120 -! - 50 write(pu,110) iv(niter), nf, v(f), reldf, preldf, v(reldx),& - v(stppar) - go to 120 -! -! *** print long summary line *** -! - 60 if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,70) - 70 format(/11h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx,& - 2x,13hmodel stppar,2x,6hd*step,2x,7hnpreldf) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,80) - 80 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx,& - 3x,6hstppar,3x,6hd*step,3x,7hnpreldf) - iv(needhd) = 0 - nreldf = zero - if (oldf .gt. zero) nreldf = v(nreduc) / oldf - if (alg .eq. 2) go to 90 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx),& - model1(m), model2(m), v(stppar), v(dstnrm), nreldf - go to 120 -! - 90 write(pu,110) iv(niter), nf, v(f), reldf, preldf,& - v(reldx), v(stppar), v(dstnrm), nreldf - 100 format(i6,i5,d10.3,2d9.2,d8.1,a3,a4,2d8.1,d9.2) - 110 format(i6,i5,d11.3,2d10.2,3d9.1,d10.2) -! - 120 if (iv(statpr) .lt. 0) go to 430 - go to (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310,& - 330, 350, 520), iv1 -! - 130 write(pu,140) - 140 format(/26h ***** x-convergence *****) - go to 430 -! - 150 write(pu,160) - 160 format(/42h ***** relative function convergence *****) - go to 430 -! - 170 write(pu,180) - 180 format(/49h ***** x- and relative function convergence *****) - go to 430 -! - 190 write(pu,200) - 200 format(/42h ***** absolute function convergence *****) - go to 430 -! - 210 write(pu,220) - 220 format(/33h ***** singular convergence *****) - go to 430 -! - 230 write(pu,240) - 240 format(/30h ***** false convergence *****) - go to 430 -! - 250 write(pu,260) - 260 format(/38h ***** function evaluation limit *****) - go to 430 -! - 270 write(pu,280) - 280 format(/28h ***** iteration limit *****) - go to 430 -! - 290 write(pu,300) - 300 format(/18h ***** stopx *****) - go to 430 -! - 310 write(pu,320) - 320 format(/44h ***** initial f(x) cannot be computed *****) -! - go to 390 -! - 330 write(pu,340) - 340 format(/37h ***** bad parameters to assess *****) - go to 999 -! - 350 write(pu,360) - 360 format(/43h ***** gradient could not be computed *****) - if (iv(niter) .gt. 0) go to 480 - go to 390 -! - 370 write(pu,380) iv(1) - 380 format(/14h ***** iv(1) =,i5,6h *****) - go to 999 -! -! *** initial call on itsum *** -! - 390 if (iv(x0prt) .ne. 0) write(pu,400) (i, x(i), d(i), i = 1, p) - 400 format(/23h i initial x(i),8x,4hd(i)//(1x,i5,d17.6,d14.3)) -! *** the following are to avoid undefined variables when the -! *** function evaluation limit is 1... - v(dstnrm) = zero - v(fdif) = zero - v(nreduc) = zero - v(preduc) = zero - v(reldx) = zero - if (iv1 .ge. 12) go to 999 - iv(needhd) = 0 - iv(prntit) = 0 - if (ol .eq. 0) go to 999 - if (ol .lt. 0 .and. alg .eq. 1) write(pu,30) - if (ol .lt. 0 .and. alg .eq. 2) write(pu,40) - if (ol .gt. 0 .and. alg .eq. 1) write(pu,70) - if (ol .gt. 0 .and. alg .eq. 2) write(pu,80) - if (alg .eq. 1) write(pu,410) v(f) - if (alg .eq. 2) write(pu,420) v(f) - 410 format(/11h 0 1,d10.3) -!365 format(/11h 0 1,e11.3) - 420 format(/11h 0 1,d11.3) - go to 999 -! -! *** print various information requested on solution *** -! - 430 iv(needhd) = 1 - if (iv(statpr) .eq. 0) go to 480 - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - preldf = zero - nreldf = zero - if (oldf .le. zero) go to 440 - preldf = v(preduc) / oldf - nreldf = v(nreduc) / oldf - 440 nf = iv(nfcall) - iv(nfcov) - ng = iv(ngcall) - iv(ngcov) - write(pu,450) v(f), v(reldx), nf, ng, preldf, nreldf - 450 format(/9h function,d17.6,8h reldx,d17.3/12h func. evals,& - i8,9x,11hgrad. evals,i8/7h preldf,d16.3,6x,7hnpreldf,d15.3) -! - if (iv(nfcov) .gt. 0) write(pu,460) iv(nfcov) - 460 format(/1x,i4,50h extra func. evals for covariance and diagnostics.) - if (iv(ngcov) .gt. 0) write(pu,470) iv(ngcov) - 470 format(1x,i4,50h extra grad. evals for covariance and diagnostics.) -! - 480 if (iv(solprt) .eq. 0) go to 999 - iv(needhd) = 1 - write(pu,490) - 490 format(/22h i final x(i),8x,4hd(i),10x,4hg(i)/) - do 500 i = 1, p - write(pu,510) i, x(i), d(i), g(i) - 500 continue - 510 format(1x,i5,d16.6,2d14.3) - go to 999 -! - 520 write(pu,530) - 530 format(/24h inconsistent dimensions) - 999 return -! *** last card of itsum follows *** - end subroutine itsum -!----------------------------------------------------------------------------- - subroutine litvmu(n, x, l, y) -! -! *** solve (l**t)*x = y, where l is an n x n lower triangular -! *** matrix stored compactly by rows. x and y may occupy the same -! *** storage. *** -! - integer :: n -!al real(kind=8) :: x(n), l(1), y(n) - real(kind=8) :: x(n), l(n*(n+1)/2), y(n) - integer :: i, ii, ij, im1, i0, j, np1 - real(kind=8) :: xi !el, zero -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -! - do 10 i = 1, n - 10 x(i) = y(i) - np1 = n + 1 - i0 = n*(n+1)/2 - do 30 ii = 1, n - i = np1 - ii - xi = x(i)/l(i0) - x(i) = xi - if (i .le. 1) go to 999 - i0 = i0 - i - if (xi .eq. zero) go to 30 - im1 = i - 1 - do 20 j = 1, im1 - ij = i0 + j - x(j) = x(j) - xi*l(ij) - 20 continue - 30 continue - 999 return -! *** last card of litvmu follows *** - end subroutine litvmu -!----------------------------------------------------------------------------- - subroutine livmul(n, x, l, y) -! -! *** solve l*x = y, where l is an n x n lower triangular -! *** matrix stored compactly by rows. x and y may occupy the same -! *** storage. *** -! - integer :: n -!al real(kind=8) :: x(n), l(1), y(n) - real(kind=8) :: x(n), l(n*(n+1)/2), y(n) -!el external dotprd -!el real(kind=8) :: dotprd - integer :: i, j, k - real(kind=8) :: t !el, zero -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -! - do 10 k = 1, n - if (y(k) .ne. zero) go to 20 - x(k) = zero - 10 continue - go to 999 - 20 j = k*(k+1)/2 - x(k) = y(k) / l(j) - if (k .ge. n) go to 999 - k = k + 1 - do 30 i = k, n - t = dotprd(i-1, l(j+1), x) - j = j + i - x(i) = (y(i) - t)/l(j) - 30 continue - 999 return -! *** last card of livmul follows *** - end subroutine livmul -!----------------------------------------------------------------------------- - subroutine parck(alg, d, iv, liv, lv, n, v) -! -! *** check ***sol (version 2.3) parameters, print changed values *** -! -! *** alg = 1 for regression, alg = 2 for general unconstrained opt. -! - integer :: alg, liv, lv, n - integer :: iv(liv) - real(kind=8) :: d(n), v(lv) -! -!el external rmdcon, vcopy, vdflt -!el real(kind=8) :: rmdcon -! rmdcon -- returns machine-dependent constants. -! vcopy -- copies one vector to another. -! vdflt -- supplies default parameter values to v alone. -!/+ -!el integer :: max0 -!/ -! -! *** local variables *** -! - integer :: i, ii, iv1, j, k, l, m, miv1, miv2, ndfalt, parsv1, pu - integer :: ijmp, jlim(2), miniv(2), ndflt(2) -!/6 -! integer varnm(2), sh(2) -! real cngd(3), dflt(3), vn(2,34), which(3) -!/7 - character(len=1) :: varnm(2), sh(2) - character(len=4) :: cngd(3), dflt(3), vn(2,34), which(3) -!/ - real(kind=8) :: big, machep, tiny, vk, vm(34), vx(34), zero -! -! *** iv and v subscripts *** -! -!el integer algsav, dinit, dtype, dtype0, epslon, inits, ivneed, -!el 1 lastiv, lastv, lmat, nextiv, nextv, nvdflt, oldn, -!el 2 parprt, parsav, perm, prunit, vneed -! -! -!/6 -! data algsav/51/, dinit/38/, dtype/16/, dtype0/54/, epslon/19/, -! 1 inits/25/, ivneed/3/, lastiv/44/, lastv/45/, lmat/42/, -! 2 nextiv/46/, nextv/47/, nvdflt/50/, oldn/38/, parprt/20/, -! 3 parsav/49/, perm/58/, prunit/21/, vneed/4/ -!/7 - integer,parameter :: algsav=51, dinit=38, dtype=16, dtype0=54, epslon=19,& - inits=25, ivneed=3, lastiv=44, lastv=45, lmat=42,& - nextiv=46, nextv=47, nvdflt=50, oldn=38, parprt=20,& - parsav=49, perm=58, prunit=21, vneed=4 - save big, machep, tiny -!/ -! - data big/0.d+0/, machep/-1.d+0/, tiny/1.d+0/, zero/0.d+0/ -!/6 -! data vn(1,1),vn(2,1)/4hepsl,4hon../ -! data vn(1,2),vn(2,2)/4hphmn,4hfc../ -! data vn(1,3),vn(2,3)/4hphmx,4hfc../ -! data vn(1,4),vn(2,4)/4hdecf,4hac../ -! data vn(1,5),vn(2,5)/4hincf,4hac../ -! data vn(1,6),vn(2,6)/4hrdfc,4hmn../ -! data vn(1,7),vn(2,7)/4hrdfc,4hmx../ -! data vn(1,8),vn(2,8)/4htune,4hr1../ -! data vn(1,9),vn(2,9)/4htune,4hr2../ -! data vn(1,10),vn(2,10)/4htune,4hr3../ -! data vn(1,11),vn(2,11)/4htune,4hr4../ -! data vn(1,12),vn(2,12)/4htune,4hr5../ -! data vn(1,13),vn(2,13)/4hafct,4hol../ -! data vn(1,14),vn(2,14)/4hrfct,4hol../ -! data vn(1,15),vn(2,15)/4hxcto,4hl.../ -! data vn(1,16),vn(2,16)/4hxfto,4hl.../ -! data vn(1,17),vn(2,17)/4hlmax,4h0.../ -! data vn(1,18),vn(2,18)/4hlmax,4hs.../ -! data vn(1,19),vn(2,19)/4hscto,4hl.../ -! data vn(1,20),vn(2,20)/4hdini,4ht.../ -! data vn(1,21),vn(2,21)/4hdtin,4hit../ -! data vn(1,22),vn(2,22)/4hd0in,4hit../ -! data vn(1,23),vn(2,23)/4hdfac,4h..../ -! data vn(1,24),vn(2,24)/4hdltf,4hdc../ -! data vn(1,25),vn(2,25)/4hdltf,4hdj../ -! data vn(1,26),vn(2,26)/4hdelt,4ha0../ -! data vn(1,27),vn(2,27)/4hfuzz,4h..../ -! data vn(1,28),vn(2,28)/4hrlim,4hit../ -! data vn(1,29),vn(2,29)/4hcosm,4hin../ -! data vn(1,30),vn(2,30)/4hhube,4hrc../ -! data vn(1,31),vn(2,31)/4hrspt,4hol../ -! data vn(1,32),vn(2,32)/4hsigm,4hin../ -! data vn(1,33),vn(2,33)/4heta0,4h..../ -! data vn(1,34),vn(2,34)/4hbias,4h..../ -!/7 - data vn(1,1),vn(2,1)/'epsl','on..'/ - data vn(1,2),vn(2,2)/'phmn','fc..'/ - data vn(1,3),vn(2,3)/'phmx','fc..'/ - data vn(1,4),vn(2,4)/'decf','ac..'/ - data vn(1,5),vn(2,5)/'incf','ac..'/ - data vn(1,6),vn(2,6)/'rdfc','mn..'/ - data vn(1,7),vn(2,7)/'rdfc','mx..'/ - data vn(1,8),vn(2,8)/'tune','r1..'/ - data vn(1,9),vn(2,9)/'tune','r2..'/ - data vn(1,10),vn(2,10)/'tune','r3..'/ - data vn(1,11),vn(2,11)/'tune','r4..'/ - data vn(1,12),vn(2,12)/'tune','r5..'/ - data vn(1,13),vn(2,13)/'afct','ol..'/ - data vn(1,14),vn(2,14)/'rfct','ol..'/ - data vn(1,15),vn(2,15)/'xcto','l...'/ - data vn(1,16),vn(2,16)/'xfto','l...'/ - data vn(1,17),vn(2,17)/'lmax','0...'/ - data vn(1,18),vn(2,18)/'lmax','s...'/ - data vn(1,19),vn(2,19)/'scto','l...'/ - data vn(1,20),vn(2,20)/'dini','t...'/ - data vn(1,21),vn(2,21)/'dtin','it..'/ - data vn(1,22),vn(2,22)/'d0in','it..'/ - data vn(1,23),vn(2,23)/'dfac','....'/ - data vn(1,24),vn(2,24)/'dltf','dc..'/ - data vn(1,25),vn(2,25)/'dltf','dj..'/ - data vn(1,26),vn(2,26)/'delt','a0..'/ - data vn(1,27),vn(2,27)/'fuzz','....'/ - data vn(1,28),vn(2,28)/'rlim','it..'/ - data vn(1,29),vn(2,29)/'cosm','in..'/ - data vn(1,30),vn(2,30)/'hube','rc..'/ - data vn(1,31),vn(2,31)/'rspt','ol..'/ - data vn(1,32),vn(2,32)/'sigm','in..'/ - data vn(1,33),vn(2,33)/'eta0','....'/ - data vn(1,34),vn(2,34)/'bias','....'/ -!/ -! - data vm(1)/1.0d-3/, vm(2)/-0.99d+0/, vm(3)/1.0d-3/, vm(4)/1.0d-2/,& - vm(5)/1.2d+0/, vm(6)/1.d-2/, vm(7)/1.2d+0/, vm(8)/0.d+0/,& - vm(9)/0.d+0/, vm(10)/1.d-3/, vm(11)/-1.d+0/, vm(13)/0.d+0/,& - vm(15)/0.d+0/, vm(16)/0.d+0/, vm(19)/0.d+0/, vm(20)/-10.d+0/,& - vm(21)/0.d+0/, vm(22)/0.d+0/, vm(23)/0.d+0/, vm(27)/1.01d+0/,& - vm(28)/1.d+10/, vm(30)/0.d+0/, vm(31)/0.d+0/, vm(32)/0.d+0/,& - vm(34)/0.d+0/ - data vx(1)/0.9d+0/, vx(2)/-1.d-3/, vx(3)/1.d+1/, vx(4)/0.8d+0/,& - vx(5)/1.d+2/, vx(6)/0.8d+0/, vx(7)/1.d+2/, vx(8)/0.5d+0/,& - vx(9)/0.5d+0/, vx(10)/1.d+0/, vx(11)/1.d+0/, vx(14)/0.1d+0/,& - vx(15)/1.d+0/, vx(16)/1.d+0/, vx(19)/1.d+0/, vx(23)/1.d+0/,& - vx(24)/1.d+0/, vx(25)/1.d+0/, vx(26)/1.d+0/, vx(27)/1.d+10/,& - vx(29)/1.d+0/, vx(31)/1.d+0/, vx(32)/1.d+0/, vx(33)/1.d+0/,& - vx(34)/1.d+0/ -! -!/6 -! data varnm(1)/1hp/, varnm(2)/1hn/, sh(1)/1hs/, sh(2)/1hh/ -! data cngd(1),cngd(2),cngd(3)/4h---c,4hhang,4hed v/, -! 1 dflt(1),dflt(2),dflt(3)/4hnond,4hefau,4hlt v/ -!/7 - data varnm(1)/'p'/, varnm(2)/'n'/, sh(1)/'s'/, sh(2)/'h'/ - data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/,& - dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/ -!/ - data ijmp/33/, jlim(1)/0/, jlim(2)/24/, ndflt(1)/32/, ndflt(2)/25/ - data miniv(1)/80/, miniv(2)/59/ -! -!............................... body ................................ -! - pu = 0 - if (prunit .le. liv) pu = iv(prunit) - if (alg .lt. 1 .or. alg .gt. 2) go to 340 - if (iv(1) .eq. 0) call deflt(alg, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .ne. 13 .and. iv1 .ne. 12) go to 10 - miv1 = miniv(alg) - if (perm .le. liv) miv1 = max0(miv1, iv(perm) - 1) - if (ivneed .le. liv) miv2 = miv1 + max0(iv(ivneed), 0) - if (lastiv .le. liv) iv(lastiv) = miv2 - if (liv .lt. miv1) go to 300 - iv(ivneed) = 0 - iv(lastv) = max0(iv(vneed), 0) + iv(lmat) - 1 - iv(vneed) = 0 - if (liv .lt. miv2) go to 300 - if (lv .lt. iv(lastv)) go to 320 - 10 if (alg .eq. iv(algsav)) go to 30 - if (pu .ne. 0) write(pu,20) alg, iv(algsav) - 20 format(/39h the first parameter to deflt should be,i3,& - 12h rather than,i3) - iv(1) = 82 - go to 999 - 30 if (iv1 .lt. 12 .or. iv1 .gt. 14) go to 60 - if (n .ge. 1) go to 50 - iv(1) = 81 - if (pu .eq. 0) go to 999 - write(pu,40) varnm(alg), n - 40 format(/8h /// bad,a1,2h =,i5) - go to 999 - 50 if (iv1 .ne. 14) iv(nextiv) = iv(perm) - if (iv1 .ne. 14) iv(nextv) = iv(lmat) - if (iv1 .eq. 13) go to 999 - k = iv(parsav) - epslon - call vdflt(alg, lv-k, v(k+1)) - iv(dtype0) = 2 - alg - iv(oldn) = n - which(1) = dflt(1) - which(2) = dflt(2) - which(3) = dflt(3) - go to 110 - 60 if (n .eq. iv(oldn)) go to 80 - iv(1) = 17 - if (pu .eq. 0) go to 999 - write(pu,70) varnm(alg), iv(oldn), n - 70 format(/5h /// ,1a1,14h changed from ,i5,4h to ,i5) - go to 999 -! - 80 if (iv1 .le. 11 .and. iv1 .ge. 1) go to 100 - iv(1) = 80 - if (pu .ne. 0) write(pu,90) iv1 - 90 format(/13h /// iv(1) =,i5,28h should be between 0 and 14.) - go to 999 -! - 100 which(1) = cngd(1) - which(2) = cngd(2) - which(3) = cngd(3) -! - 110 if (iv1 .eq. 14) iv1 = 12 - if (big .gt. tiny) go to 120 - tiny = rmdcon(1) - machep = rmdcon(3) - big = rmdcon(6) - vm(12) = machep - vx(12) = big - vx(13) = big - vm(14) = machep - vm(17) = tiny - vx(17) = big - vm(18) = tiny - vx(18) = big - vx(20) = big - vx(21) = big - vx(22) = big - vm(24) = machep - vm(25) = machep - vm(26) = machep - vx(28) = rmdcon(5) - vm(29) = machep - vx(30) = big - vm(33) = machep - 120 m = 0 - i = 1 - j = jlim(alg) - k = epslon - ndfalt = ndflt(alg) - do 150 l = 1, ndfalt - vk = v(k) - if (vk .ge. vm(i) .and. vk .le. vx(i)) go to 140 - m = k - if (pu .ne. 0) write(pu,130) vn(1,i), vn(2,i), k, vk,& - vm(i), vx(i) - 130 format(/6h /// ,2a4,5h.. v(,i2,3h) =,d11.3,7h should,& - 11h be between,d11.3,4h and,d11.3) - 140 k = k + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 150 continue -! - if (iv(nvdflt) .eq. ndfalt) go to 170 - iv(1) = 51 - if (pu .eq. 0) go to 999 - write(pu,160) iv(nvdflt), ndfalt - 160 format(/13h iv(nvdflt) =,i5,13h rather than ,i5) - go to 999 - 170 if ((iv(dtype) .gt. 0 .or. v(dinit) .gt. zero) .and. iv1 .eq. 12) & - go to 200 - do 190 i = 1, n - if (d(i) .gt. zero) go to 190 - m = 18 - if (pu .ne. 0) write(pu,180) i, d(i) - 180 format(/8h /// d(,i3,3h) =,d11.3,19h should be positive) - 190 continue - 200 if (m .eq. 0) go to 210 - iv(1) = m - go to 999 -! - 210 if (pu .eq. 0 .or. iv(parprt) .eq. 0) go to 999 - if (iv1 .ne. 12 .or. iv(inits) .eq. alg-1) go to 230 - m = 1 - write(pu,220) sh(alg), iv(inits) - 220 format(/22h nondefault values..../5h init,a1,14h..... iv(25) =,& - i3) - 230 if (iv(dtype) .eq. iv(dtype0)) go to 250 - if (m .eq. 0) write(pu,260) which - m = 1 - write(pu,240) iv(dtype) - 240 format(20h dtype..... iv(16) =,i3) - 250 i = 1 - j = jlim(alg) - k = epslon - l = iv(parsav) - ndfalt = ndflt(alg) - do 290 ii = 1, ndfalt - if (v(k) .eq. v(l)) go to 280 - if (m .eq. 0) write(pu,260) which - 260 format(/1h ,3a4,9halues..../) - m = 1 - write(pu,270) vn(1,i), vn(2,i), k, v(k) - 270 format(1x,2a4,5h.. v(,i2,3h) =,d15.7) - 280 k = k + 1 - l = l + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 290 continue -! - iv(dtype0) = iv(dtype) - parsv1 = iv(parsav) - call vcopy(iv(nvdflt), v(parsv1), v(epslon)) - go to 999 -! - 300 iv(1) = 15 - if (pu .eq. 0) go to 999 - write(pu,310) liv, miv2 - 310 format(/10h /// liv =,i5,17h must be at least,i5) - if (liv .lt. miv1) go to 999 - if (lv .lt. iv(lastv)) go to 320 - go to 999 -! - 320 iv(1) = 16 - if (pu .eq. 0) go to 999 - write(pu,330) lv, iv(lastv) - 330 format(/9h /// lv =,i5,17h must be at least,i5) - go to 999 -! - 340 iv(1) = 67 - if (pu .eq. 0) go to 999 - write(pu,350) alg - 350 format(/10h /// alg =,i5,15h must be 1 or 2) -! - 999 return -! *** last card of parck follows *** - end subroutine parck -!----------------------------------------------------------------------------- - real(kind=8) function reldst(p, d, x, x0) -! -! *** compute and return relative difference between x and x0 *** -! *** nl2sol version 2.2 *** -! - integer :: p - real(kind=8) :: d(p), x(p), x0(p) -!/+ -!el real(kind=8) :: dabs -!/ - integer :: i - real(kind=8) :: emax, t, xmax !el, zero -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -! - emax = zero - xmax = zero - do 10 i = 1, p - t = dabs(d(i) * (x(i) - x0(i))) - if (emax .lt. t) emax = t - t = d(i) * (dabs(x(i)) + dabs(x0(i))) - if (xmax .lt. t) xmax = t - 10 continue - reldst = zero - if (xmax .gt. zero) reldst = emax / xmax - 999 return -! *** last card of reldst follows *** - end function reldst -!----------------------------------------------------------------------------- - subroutine vaxpy(p, w, a, x, y) -! -! *** set w = a*x + y -- w, x, y = p-vectors, a = scalar *** -! - integer :: p - real(kind=8) :: a, w(p), x(p), y(p) -! - integer :: i -! - do 10 i = 1, p - 10 w(i) = a*x(i) + y(i) - return - end subroutine vaxpy -!----------------------------------------------------------------------------- - subroutine vcopy(p, y, x) -! -! *** set y = x, where x and y are p-vectors *** -! - integer :: p - real(kind=8) :: x(p), y(p) -! - integer :: i -! - do 10 i = 1, p - 10 y(i) = x(i) - return - end subroutine vcopy -!----------------------------------------------------------------------------- - subroutine vdflt(alg, lv, v) -! -! *** supply ***sol (version 2.3) default values to v *** -! -! *** alg = 1 means regression constants. -! *** alg = 2 means general unconstrained optimization constants. -! - integer :: alg, l,lv - real(kind=8) :: v(lv) -!/+ -!el real(kind=8) :: dmax1 -!/ -!el external rmdcon -!el real(kind=8) :: rmdcon -! rmdcon... returns machine-dependent constants -! - real(kind=8) :: machep, mepcrt, sqteps !el one, three -! -! *** subscripts for v *** -! -!el integer afctol, bias, cosmin, decfac, delta0, dfac, dinit, dltfdc, -!el 1 dltfdj, dtinit, d0init, epslon, eta0, fuzz, huberc, -!el 2 incfac, lmax0, lmaxs, phmnfc, phmxfc, rdfcmn, rdfcmx, -!el 3 rfctol, rlimit, rsptol, sctol, sigmin, tuner1, tuner2, -!el 4 tuner3, tuner4, tuner5, xctol, xftol -! -!/6 -! data one/1.d+0/, three/3.d+0/ -!/7 - real(kind=8),parameter :: one=1.d+0, three=3.d+0 -!/ -! -! *** v subscript values *** -! -!/6 -! data afctol/31/, bias/43/, cosmin/47/, decfac/22/, delta0/44/, -! 1 dfac/41/, dinit/38/, dltfdc/42/, dltfdj/43/, dtinit/39/, -! 2 d0init/40/, epslon/19/, eta0/42/, fuzz/45/, huberc/48/, -! 3 incfac/23/, lmax0/35/, lmaxs/36/, phmnfc/20/, phmxfc/21/, -! 4 rdfcmn/24/, rdfcmx/25/, rfctol/32/, rlimit/46/, rsptol/49/, -! 5 sctol/37/, sigmin/50/, tuner1/26/, tuner2/27/, tuner3/28/, -! 6 tuner4/29/, tuner5/30/, xctol/33/, xftol/34/ -!/7 - integer,parameter :: afctol=31, bias=43, cosmin=47, decfac=22, delta0=44,& - dfac=41, dinit=38, dltfdc=42, dltfdj=43, dtinit=39,& - d0init=40, epslon=19, eta0=42, fuzz=45, huberc=48,& - incfac=23, lmax0=35, lmaxs=36, phmnfc=20, phmxfc=21,& - rdfcmn=24, rdfcmx=25, rfctol=32, rlimit=46, rsptol=49,& - sctol=37, sigmin=50, tuner1=26, tuner2=27, tuner3=28,& - tuner4=29, tuner5=30, xctol=33, xftol=34 -!/ -! -!------------------------------- body -------------------------------- -! - machep = rmdcon(3) - v(afctol) = 1.d-20 - if (machep .gt. 1.d-10) v(afctol) = machep**2 - v(decfac) = 0.5d+0 - sqteps = rmdcon(4) - v(dfac) = 0.6d+0 - v(delta0) = sqteps - v(dtinit) = 1.d-6 - mepcrt = machep ** (one/three) - v(d0init) = 1.d+0 - v(epslon) = 0.1d+0 - v(incfac) = 2.d+0 - v(lmax0) = 1.d+0 - v(lmaxs) = 1.d+0 - v(phmnfc) = -0.1d+0 - v(phmxfc) = 0.1d+0 - v(rdfcmn) = 0.1d+0 - v(rdfcmx) = 4.d+0 - v(rfctol) = dmax1(1.d-10, mepcrt**2) - v(sctol) = v(rfctol) - v(tuner1) = 0.1d+0 - v(tuner2) = 1.d-4 - v(tuner3) = 0.75d+0 - v(tuner4) = 0.5d+0 - v(tuner5) = 0.75d+0 - v(xctol) = sqteps - v(xftol) = 1.d+2 * machep -! - if (alg .ge. 2) go to 10 -! -! *** regression values -! - v(cosmin) = dmax1(1.d-6, 1.d+2 * machep) - v(dinit) = 0.d+0 - v(dltfdc) = mepcrt - v(dltfdj) = sqteps - v(fuzz) = 1.5d+0 - v(huberc) = 0.7d+0 - v(rlimit) = rmdcon(5) - v(rsptol) = 1.d-3 - v(sigmin) = 1.d-4 - go to 999 -! -! *** general optimization values -! - 10 v(bias) = 0.8d+0 - v(dinit) = -1.0d+0 - v(eta0) = 1.0d+3 * machep -! - 999 return -! *** last card of vdflt follows *** - end subroutine vdflt -!----------------------------------------------------------------------------- - subroutine vscopy(p, y, s) -! -! *** set p-vector y to scalar s *** -! - integer :: p - real(kind=8) :: s, y(p) -! - integer :: i -! - do 10 i = 1, p - 10 y(i) = s - return - end subroutine vscopy -!----------------------------------------------------------------------------- - real(kind=8) function v2norm(p, x) -! -! *** return the 2-norm of the p-vector x, taking *** -! *** care to avoid the most likely underflows. *** -! - integer :: p - real(kind=8) :: x(p) -! - integer :: i, j - real(kind=8) :: r, scale, sqteta, t, xi !el, one, zero -!/+ -!el real(kind=8) :: dabs, dsqrt -!/ -!el external rmdcon -!el real(kind=8) :: rmdcon -! -!/6 -! data one/1.d+0/, zero/0.d+0/ -!/7 - real(kind=8),parameter :: one=1.d+0, zero=0.d+0 - save sqteta -!/ - data sqteta/0.d+0/ -! - if (p .gt. 0) go to 10 - v2norm = zero - go to 999 - 10 do 20 i = 1, p - if (x(i) .ne. zero) go to 30 - 20 continue - v2norm = zero - go to 999 -! - 30 scale = dabs(x(i)) - if (i .lt. p) go to 40 - v2norm = scale - go to 999 - 40 t = one - if (sqteta .eq. zero) sqteta = rmdcon(2) -! -! *** sqteta is (slightly larger than) the square root of the -! *** smallest positive floating point number on the machine. -! *** the tests involving sqteta are done to prevent underflows. -! - j = i + 1 - do 60 i = j, p - xi = dabs(x(i)) - if (xi .gt. scale) go to 50 - r = xi / scale - if (r .gt. sqteta) t = t + r*r - go to 60 - 50 r = scale / xi - if (r .le. sqteta) r = zero - t = one + t * r*r - scale = xi - 60 continue -! - v2norm = scale * dsqrt(t) - 999 return -! *** last card of v2norm follows *** - end function v2norm -!----------------------------------------------------------------------------- - subroutine humsl(n,d,x,calcf,calcgh,iv,liv,lv,v,uiparm,urparm,ufparm) -! -! *** minimize general unconstrained objective function using *** -! *** (analytic) gradient and hessian provided by the caller. *** -! - integer :: liv, lv, n - integer :: iv(liv), uiparm(1) - real(kind=8) :: d(n), x(n), v(lv), urparm(1) - real(kind=8),external :: ufparm -! dimension v(78 + n*(n+12)), uiparm(*), urparm(*) - external :: calcf, calcgh -! -!------------------------------ discussion --------------------------- -! -! this routine is like sumsl, except that the subroutine para- -! meter calcg of sumsl (which computes the gradient of the objec- -! tive function) is replaced by the subroutine parameter calcgh, -! which computes both the gradient and (lower triangle of the) -! hessian of the objective function. the calling sequence is... -! call calcgh(n, x, nf, g, h, uiparm, urparm, ufparm) -! parameters n, x, nf, g, uiparm, urparm, and ufparm are the same -! as for sumsl, while h is an array of length n*(n+1)/2 in which -! calcgh must store the lower triangle of the hessian at x. start- -! ing at h(1), calcgh must store the hessian entries in the order -! (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... -! the value printed (by itsum) in the column labelled stppar -! is the levenberg-marquardt used in computing the current step. -! zero means a full newton step. if the special case described in -! ref. 1 is detected, then stppar is negated. the value printed -! in the column labelled npreldf is zero if the current hessian -! is not positive definite. -! it sometimes proves worthwhile to let d be determined from the -! diagonal of the hessian matrix by setting iv(dtype) = 1 and -! v(dinit) = 0. the following iv and v components are relevant... -! -! iv(dtol)..... iv(59) gives the starting subscript in v of the dtol -! array used when d is updated. (iv(dtol) can be -! initialized by calling humsl with iv(1) = 13.) -! iv(dtype).... iv(16) tells how the scale vector d should be chosen. -! iv(dtype) .le. 0 means that d should not be updated, and -! iv(dtype) .ge. 1 means that d should be updated as -! described below with v(dfac). default = 0. -! v(dfac)..... v(41) and the dtol and d0 arrays (see v(dtinit) and -! v(d0init)) are used in updating the scale vector d when -! iv(dtype) .gt. 0. (d is initialized according to -! v(dinit), described in sumsl.) let -! d1(i) = max(sqrt(abs(h(i,i))), v(dfac)*d(i)), -! where h(i,i) is the i-th diagonal element of the current -! hessian. if iv(dtype) = 1, then d(i) is set to d1(i) -! unless d1(i) .lt. dtol(i), in which case d(i) is set to -! max(d0(i), dtol(i)). -! if iv(dtype) .ge. 2, then d is updated during the first -! iteration as for iv(dtype) = 1 (after any initialization -! due to v(dinit)) and is left unchanged thereafter. -! default = 0.6. -! v(dtinit)... v(39), if positive, is the value to which all components -! of the dtol array (see v(dfac)) are initialized. if -! v(dtinit) = 0, then it is assumed that the caller has -! stored dtol in v starting at v(iv(dtol)). -! default = 10**-6. -! v(d0init)... v(40), if positive, is the value to which all components -! of the d0 vector (see v(dfac)) are initialized. if -! v(dfac) = 0, then it is assumed that the caller has -! stored d0 in v starting at v(iv(dtol)+n). default = 1.0. -! -! *** reference *** -! -! 1. gay, d.m. (1981), computing optimal locally constrained steps, -! siam j. sci. statist. comput. 2, pp. 186-197. -!. -! *** general *** -! -! coded by david m. gay (winter 1980). revised sept. 1982. -! this subroutine was written in connection with research supported -! in part by the national science foundation under grants -! mcs-7600324 and mcs-7906671. -! -!---------------------------- declarations --------------------------- -! -!el external deflt, humit -! -! deflt... provides default input values for iv and v. -! humit... reverse-communication routine that does humsl algorithm. -! - integer :: g1, h1, iv1, lh, nf - real(kind=8) :: f -! -! *** subscripts for iv *** -! -!el integer g, h, nextv, nfcall, nfgcal, toobig, vneed -! -!/6 -! data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, h/56/, toobig/2/, -! 1 vneed/4/ -!/7 - integer,parameter :: nextv=47, nfcall=6, nfgcal=7, g=28, h=56,& - toobig=2,vneed=4 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! - lh = n * (n + 1) / 2 - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) & - iv(vneed) = iv(vneed) + n*(n+3)/2 - iv1 = iv(1) - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - h1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -! - 10 g1 = iv(g) - h1 = iv(h) -! - 20 call humit(d, f, v(g1), v(h1), iv, lh, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -! - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -! - 40 call calcgh(n, x, iv(nfgcal), v(g1), v(h1), uiparm, urparm,& - ufparm) - go to 20 -! - 50 if (iv(1) .ne. 14) go to 999 -! -! *** storage allocation -! - iv(g) = iv(nextv) - iv(h) = iv(g) + n - iv(nextv) = iv(h) + n*(n+1)/2 - if (iv1 .ne. 13) go to 10 -! - 999 return -! *** last card of humsl follows *** - end subroutine humsl -!----------------------------------------------------------------------------- - subroutine humit(d, fx, g, h, iv, lh, liv, lv, n, v, x) -! -! *** carry out humsl (unconstrained minimization) iterations, using -! *** hessian matrix provided by the caller. -! -!el use control - use control, only:stopx - -! *** parameter declarations *** -! - integer :: lh, liv, lv, n - integer :: iv(liv) - real(kind=8) :: d(n), fx, g(n), h(lh), v(lv), x(n) -! -!-------------------------- parameter usage -------------------------- -! -! d.... scale vector. -! fx... function value. -! g.... gradient vector. -! h.... lower triangle of the hessian, stored rowwise. -! iv... integer value array. -! lh... length of h = p*(p+1)/2. -! liv.. length of iv (at least 60). -! lv... length of v (at least 78 + n*(n+21)/2). -! n.... number of variables (components in x and g). -! v.... floating-point value array. -! x.... parameter vector. -! -! *** discussion *** -! -! parameters iv, n, v, and x are the same as the corresponding -! ones to humsl (which see), except that v can be shorter (since -! the part of v that humsl uses for storing g and h is not needed). -! moreover, compared with humsl, iv(1) may have the two additional -! output values 1 and 2, which are explained below, as is the use -! of iv(toobig) and iv(nfgcal). the value iv(g), which is an -! output value from humsl, is not referenced by humit or the -! subroutines it calls. -! -! iv(1) = 1 means the caller should set fx to f(x), the function value -! at x, and call humit again, having changed none of the -! other parameters. an exception occurs if f(x) cannot be -! computed (e.g. if overflow would occur), which may happen -! because of an oversized step. in this case the caller -! should set iv(toobig) = iv(2) to 1, which will cause -! humit to ignore fx and try a smaller step. the para- -! meter nf that humsl passes to calcf (for possible use by -! calcgh) is a copy of iv(nfcall) = iv(6). -! iv(1) = 2 means the caller should set g to g(x), the gradient of f at -! x, and h to the lower triangle of h(x), the hessian of f -! at x, and call humit again, having changed none of the -! other parameters except perhaps the scale vector d. -! the parameter nf that humsl passes to calcg is -! iv(nfgcal) = iv(7). if g(x) and h(x) cannot be evaluated, -! then the caller may set iv(nfgcal) to 0, in which case -! humit will return with iv(1) = 65. -! note -- humit overwrites h with the lower triangle -! of diag(d)**-1 * h(x) * diag(d)**-1. -!. -! *** general *** -! -! coded by david m. gay (winter 1980). revised sept. 1982. -! this subroutine was written in connection with research supported -! in part by the national science foundation under grants -! mcs-7600324 and mcs-7906671. -! -! (see sumsl and humsl for references.) -! -!+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -! -! *** local variables *** -! - integer :: dg1, dummy, i, j, k, l, lstgst, nn1o2, step1,& - temp1, w1, x01 - real(kind=8) :: t -! -! *** constants *** -! -!el real(kind=8) :: one, onep2, zero -! -! *** no intrinsic functions *** -! -! *** external functions and subroutines *** -! -!el external assst, deflt, dotprd, dupdu, gqtst, itsum, parck, -!el 1 reldst, slvmul, stopx, vaxpy, vcopy, vscopy, v2norm -!el logical stopx -!el real(kind=8) :: dotprd, reldst, v2norm -! -! assst.... assesses candidate step. -! deflt.... provides default iv and v input values. -! dotprd... returns inner product of two vectors. -! dupdu.... updates scale vector d. -! gqtst.... computes optimally locally constrained step. -! itsum.... prints iteration summary and info on initial and final x. -! parck.... checks validity of input iv and v values. -! reldst... computes v(reldx) = relative step size. -! slvmul... multiplies symmetric matrix times vector, given the lower -! triangle of the matrix. -! stopx.... returns .true. if the break key has been pressed. -! vaxpy.... computes scalar times one vector plus another. -! vcopy.... copies one vector to another. -! vscopy... sets all elements of a vector to a scalar. -! v2norm... returns the 2-norm of a vector. -! -! *** subscripts for iv and v *** -! -!el integer cnvcod, dg, dgnorm, dinit, dstnrm, dtinit, dtol, -!el 1 dtype, d0init, f, f0, fdif, gtstep, incfac, irc, kagqt, -!el 2 lmat, lmax0, lmaxs, mode, model, mxfcal, mxiter, nextv, -!el 3 nfcall, nfgcal, ngcall, niter, preduc, radfac, radinc, -!el 4 radius, rad0, reldx, restor, step, stglim, stlstg, stppar, -!el 5 toobig, tuner4, tuner5, vneed, w, xirc, x0 -! -! *** iv subscript values *** -! -!/6 -! data cnvcod/55/, dg/37/, dtol/59/, dtype/16/, irc/29/, kagqt/33/, -! 1 lmat/42/, mode/35/, model/5/, mxfcal/17/, mxiter/18/, -! 2 nextv/47/, nfcall/6/, nfgcal/7/, ngcall/30/, niter/31/, -! 3 radinc/8/, restor/9/, step/40/, stglim/11/, stlstg/41/, -! 4 toobig/2/, vneed/4/, w/34/, xirc/13/, x0/43/ -!/7 - integer,parameter :: cnvcod=55, dg=37, dtol=59, dtype=16, irc=29, kagqt=33,& - lmat=42, mode=35, model=5, mxfcal=17, mxiter=18,& - nextv=47, nfcall=6, nfgcal=7, ngcall=30, niter=31,& - radinc=8, restor=9, step=40, stglim=11, stlstg=41,& - toobig=2, vneed=4, w=34, xirc=13, x0=43 -!/ -! -! *** v subscript values *** -! -!/6 -! data dgnorm/1/, dinit/38/, dstnrm/2/, dtinit/39/, d0init/40/, -! 1 f/10/, f0/13/, fdif/11/, gtstep/4/, incfac/23/, lmax0/35/, -! 2 lmaxs/36/, preduc/7/, radfac/16/, radius/8/, rad0/9/, -! 3 reldx/17/, stppar/5/, tuner4/29/, tuner5/30/ -!/7 - integer,parameter :: dgnorm=1, dinit=38, dstnrm=2, dtinit=39, d0init=40,& - f=10, f0=13, fdif=11, gtstep=4, incfac=23, lmax0=35,& - lmaxs=36, preduc=7, radfac=16, radius=8, rad0=9,& - reldx=17, stppar=5, tuner4=29, tuner5=30 -!/ -! -!/6 -! data one/1.d+0/, onep2/1.2d+0/, zero/0.d+0/ -!/7 - real(kind=8),parameter :: one=1.d+0, onep2=1.2d+0, zero=0.d+0 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! - i = iv(1) - if (i .eq. 1) go to 30 - if (i .eq. 2) go to 40 -! -! *** check validity of iv and v input values *** -! - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) & - iv(vneed) = iv(vneed) + n*(n+21)/2 + 7 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - nn1o2 = n * (n + 1) / 2 - if (lh .ge. nn1o2) go to (210,210,210,210,210,210,160,120,160,& - 10,10,20), i - iv(1) = 66 - go to 350 -! -! *** storage allocation *** -! - 10 iv(dtol) = iv(lmat) + nn1o2 - iv(x0) = iv(dtol) + 2*n - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(dg) = iv(stlstg) + n - iv(w) = iv(dg) + n - iv(nextv) = iv(w) + 4*n + 7 - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -! -! *** initialization *** -! - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - v(stppar) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - k = iv(dtol) - if (v(dtinit) .gt. zero) call vscopy(n, v(k), v(dtinit)) - k = k + n - if (v(d0init) .gt. zero) call vscopy(n, v(k), v(d0init)) - iv(1) = 1 - go to 999 -! - 30 v(f) = fx - if (iv(mode) .ge. 0) go to 210 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 350 -! -! *** make sure gradient could be computed *** -! - 40 if (iv(nfgcal) .ne. 0) go to 50 - iv(1) = 65 - go to 350 -! -! *** update the scale vector d *** -! - 50 dg1 = iv(dg) - if (iv(dtype) .le. 0) go to 70 - k = dg1 - j = 0 - do 60 i = 1, n - j = j + i - v(k) = h(j) - k = k + 1 - 60 continue - call dupdu(d, v(dg1), iv, liv, lv, n, v) -! -! *** compute scaled gradient and its norm *** -! - 70 dg1 = iv(dg) - k = dg1 - do 80 i = 1, n - v(k) = g(i) / d(i) - k = k + 1 - 80 continue - v(dgnorm) = v2norm(n, v(dg1)) -! -! *** compute scaled hessian *** -! - k = 1 - do 100 i = 1, n - t = one / d(i) - do 90 j = 1, i - h(k) = t * h(k) / d(j) - k = k + 1 - 90 continue - 100 continue -! - if (iv(cnvcod) .ne. 0) go to 340 - if (iv(mode) .eq. 0) go to 300 -! -! *** allow first step to have scaled 2-norm at most v(lmax0) *** -! - v(radius) = v(lmax0) -! - iv(mode) = 0 -! -! -!----------------------------- main loop ----------------------------- -! -! -! *** print iteration summary, check iteration limit *** -! - 110 call itsum(d, g, iv, liv, lv, n, v, x) - 120 k = iv(niter) - if (k .lt. iv(mxiter)) go to 130 - iv(1) = 10 - go to 350 -! - 130 iv(niter) = k + 1 -! -! *** initialize for start of next iteration *** -! - dg1 = iv(dg) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -! -! *** copy x to x0 *** -! - call vcopy(n, v(x01), x) -! -! *** update radius *** -! - if (k .eq. 0) go to 150 - step1 = iv(step) - k = step1 - do 140 i = 1, n - v(k) = d(i) * v(k) - k = k + 1 - 140 continue - v(radius) = v(radfac) * v2norm(n, v(step1)) -! -! *** check stopx and function evaluation limit *** -! -! AL 4/30/95 - dummy=iv(nfcall) - 150 if (.not. stopx(dummy)) go to 170 - iv(1) = 11 - go to 180 -! -! *** come here when restarting after func. eval. limit or stopx. -! - 160 if (v(f) .ge. v(f0)) go to 170 - v(radfac) = one - k = iv(niter) - go to 130 -! - 170 if (iv(nfcall) .lt. iv(mxfcal)) go to 190 - iv(1) = 9 - 180 if (v(f) .ge. v(f0)) go to 350 -! -! *** in case of stopx or function evaluation limit with -! *** improved v(f), evaluate the gradient at x. -! - iv(cnvcod) = iv(1) - go to 290 -! -!. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -! - 190 step1 = iv(step) - dg1 = iv(dg) - l = iv(lmat) - w1 = iv(w) - call gqtst(d, v(dg1), h, iv(kagqt), v(l), n, v(step1), v, v(w1)) - if (iv(irc) .eq. 6) go to 210 -! -! *** check whether evaluating f(x0 + step) looks worthwhile *** -! - if (v(dstnrm) .le. zero) go to 210 - if (iv(irc) .ne. 5) go to 200 - if (v(radfac) .le. one) go to 200 - if (v(preduc) .le. onep2 * v(fdif)) go to 210 -! -! *** compute f(x0 + step) *** -! - 200 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -! -!. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -! - 210 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 220 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -! - 220 k = iv(irc) - go to (230,260,260,260,230,240,250,250,250,250,250,250,330,300), k -! -! *** recompute step with new radius *** -! - 230 v(radius) = v(radfac) * v(dstnrm) - go to 150 -! -! *** compute step of length v(lmaxs) for singular convergence test. -! - 240 v(radius) = v(lmaxs) - go to 190 -! -! *** convergence or false convergence *** -! - 250 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 340 - if (iv(xirc) .eq. 14) go to 340 - iv(xirc) = 14 -! -!. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -! - 260 if (iv(irc) .ne. 3) go to 290 - temp1 = lstgst -! -! *** prepare for gradient tests *** -! *** set temp1 = hessian * step + g(x0) -! *** = diag(d) * (h * step + g(x0)) -! -! use x0 vector as temporary. - k = x01 - do 270 i = 1, n - v(k) = d(i) * v(step1) - k = k + 1 - step1 = step1 + 1 - 270 continue - call slvmul(n, v(temp1), h, v(x01)) - do 280 i = 1, n - v(temp1) = d(i) * v(temp1) + g(i) - temp1 = temp1 + 1 - 280 continue -! -! *** compute gradient and hessian *** -! - 290 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -! - 300 iv(1) = 2 - if (iv(irc) .ne. 3) go to 110 -! -! *** set v(radfac) by gradient tests *** -! - temp1 = iv(stlstg) - step1 = iv(step) -! -! *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -! - k = temp1 - do 310 i = 1, n - v(k) = (v(k) - g(i)) / d(i) - k = k + 1 - 310 continue -! -! *** do gradient tests *** -! - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) go to 320 - if (dotprd(n, g, v(step1)) & - .ge. v(gtstep) * v(tuner5)) go to 110 - 320 v(radfac) = v(incfac) - go to 110 -! -!. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -! -! *** bad parameters to assess *** -! - 330 iv(1) = 64 - go to 350 -! -! *** print summary of final iteration and other requested items *** -! - 340 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 350 call itsum(d, g, iv, liv, lv, n, v, x) -! - 999 return -! -! *** last card of humit follows *** - end subroutine humit -!----------------------------------------------------------------------------- - subroutine dupdu(d, hdiag, iv, liv, lv, n, v) -! -! *** update scale vector d for humsl *** -! -! *** parameter declarations *** -! - integer :: liv, lv, n - integer :: iv(liv) - real(kind=8) :: d(n), hdiag(n), v(lv) -! -! *** local variables *** -! - integer :: dtoli, d0i, i - real(kind=8) :: t, vdfac -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dabs, dmax1, dsqrt -!/ -! *** subscripts for iv and v *** -! -!el integer :: dfac, dtol, dtype, niter -!/6 -! data dfac/41/, dtol/59/, dtype/16/, niter/31/ -!/7 - integer,parameter :: dfac=41, dtol=59, dtype=16, niter=31 -!/ -! -!------------------------------- body -------------------------------- -! - i = iv(dtype) - if (i .eq. 1) go to 10 - if (iv(niter) .gt. 0) go to 999 -! - 10 dtoli = iv(dtol) - d0i = dtoli + n - vdfac = v(dfac) - do 20 i = 1, n - t = dmax1(dsqrt(dabs(hdiag(i))), vdfac*d(i)) - if (t .lt. v(dtoli)) t = dmax1(v(dtoli), v(d0i)) - d(i) = t - dtoli = dtoli + 1 - d0i = d0i + 1 - 20 continue -! - 999 return -! *** last card of dupdu follows *** - end subroutine dupdu -!----------------------------------------------------------------------------- - subroutine gqtst(d, dig, dihdi, ka, l, p, step, v, w) -! -! *** compute goldfeld-quandt-trotter step by more-hebden technique *** -! *** (nl2sol version 2.2), modified a la more and sorensen *** -! -! *** parameter declarations *** -! - integer :: ka, p -!al real(kind=8) :: d(p), dig(p), dihdi(1), l(1), v(21), step(p), -!al 1 w(1) - real(kind=8) :: d(p), dig(p), dihdi(p*(p+1)/2), l(p*(p+1)/2),& - v(21), step(p),w(4*p+7) -! dimension dihdi(p*(p+1)/2), l(p*(p+1)/2), w(4*p+7) -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -! *** purpose *** -! -! given the (compactly stored) lower triangle of a scaled -! hessian (approximation) and a nonzero scaled gradient vector, -! this subroutine computes a goldfeld-quandt-trotter step of -! approximate length v(radius) by the more-hebden technique. in -! other words, step is computed to (approximately) minimize -! psi(step) = (g**t)*step + 0.5*(step**t)*h*step such that the -! 2-norm of d*step is at most (approximately) v(radius), where -! g is the gradient, h is the hessian, and d is a diagonal -! scale matrix whose diagonal is stored in the parameter d. -! (gqtst assumes dig = d**-1 * g and dihdi = d**-1 * h * d**-1.) -! -! *** parameter description *** -! -! d (in) = the scale vector, i.e. the diagonal of the scale -! matrix d mentioned above under purpose. -! dig (in) = the scaled gradient vector, d**-1 * g. if g = 0, then -! step = 0 and v(stppar) = 0 are returned. -! dihdi (in) = lower triangle of the scaled hessian (approximation), -! i.e., d**-1 * h * d**-1, stored compactly by rows., i.e., -! in the order (1,1), (2,1), (2,2), (3,1), (3,2), etc. -! ka (i/o) = the number of hebden iterations (so far) taken to deter- -! mine step. ka .lt. 0 on input means this is the first -! attempt to determine step (for the present dig and dihdi) -! -- ka is initialized to 0 in this case. output with -! ka = 0 (or v(stppar) = 0) means step = -(h**-1)*g. -! l (i/o) = workspace of length p*(p+1)/2 for cholesky factors. -! p (in) = number of parameters -- the hessian is a p x p matrix. -! step (i/o) = the step computed. -! v (i/o) contains various constants and variables described below. -! w (i/o) = workspace of length 4*p + 6. -! -! *** entries in v *** -! -! v(dgnorm) (i/o) = 2-norm of (d**-1)*g. -! v(dstnrm) (output) = 2-norm of d*step. -! v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or -! overestimate of smallest eigenvalue of (d**-1)*h*(d**-1). -! v(epslon) (in) = max. rel. error allowed for psi(step). for the -! step returned, psi(step) will exceed its optimal value -! by less than -v(epslon)*psi(step). suggested value = 0.1. -! v(gtstep) (out) = inner product between g and step. -! v(nreduc) (out) = psi(-(h**-1)*g) = psi(newton step) (for pos. def. -! h only -- v(nreduc) is set to zero otherwise). -! v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step -! (more*s sigma). the error v(dstnrm) - v(radius) must lie -! between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). -! v(phmxfc) (in) (see v(phmnfc).) -! suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5. -! v(preduc) (out) = psi(step) = predicted obj. func. reduction for step. -! v(radius) (in) = radius of current (scaled) trust region. -! v(rad0) (i/o) = value of v(radius) from previous call. -! v(stppar) (i/o) is normally the marquardt parameter, i.e. the alpha -! described below under algorithm notes. if h + alpha*d**2 -! (see algorithm notes) is (nearly) singular, however, -! then v(stppar) = -alpha. -! -! *** usage notes *** -! -! if it is desired to recompute step using a different value of -! v(radius), then this routine may be restarted by calling it -! with all parameters unchanged except v(radius). (this explains -! why step and w are listed as i/o). on an initial call (one with -! ka .lt. 0), step and w need not be initialized and only compo- -! nents v(epslon), v(stppar), v(phmnfc), v(phmxfc), v(radius), and -! v(rad0) of v must be initialized. -! -! *** algorithm notes *** -! -! the desired g-q-t step (ref. 2, 3, 4, 6) satisfies -! (h + alpha*d**2)*step = -g for some nonnegative alpha such that -! h + alpha*d**2 is positive semidefinite. alpha and step are -! computed by a scheme analogous to the one described in ref. 5. -! estimates of the smallest and largest eigenvalues of the hessian -! are obtained from the gerschgorin circle theorem enhanced by a -! simple form of the scaling described in ref. 7. cases in which -! h + alpha*d**2 is nearly (or exactly) singular are handled by -! the technique discussed in ref. 2. in these cases, a step of -! (exact) length v(radius) is returned for which psi(step) exceeds -! its optimal value by less than -v(epslon)*psi(step). the test -! suggested in ref. 6 for detecting the special case is performed -! once two matrix factorizations have been done -- doing so sooner -! seems to degrade the performance of optimization routines that -! call this routine. -! -! *** functions and subroutines called *** -! -! dotprd - returns inner product of two vectors. -! litvmu - applies inverse-transpose of compact lower triang. matrix. -! livmul - applies inverse of compact lower triang. matrix. -! lsqrt - finds cholesky factor (of compactly stored lower triang.). -! lsvmin - returns approx. to min. sing. value of lower triang. matrix. -! rmdcon - returns machine-dependent constants. -! v2norm - returns 2-norm of a vector. -! -! *** references *** -! -! 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), an adaptive -! nonlinear least-squares algorithm, acm trans. math. -! software, vol. 7, no. 3. -! 2. gay, d.m. (1981), computing optimal locally constrained steps, -! siam j. sci. statist. computing, vol. 2, no. 2, pp. -! 186-197. -! 3. goldfeld, s.m., quandt, r.e., and trotter, h.f. (1966), -! maximization by quadratic hill-climbing, econometrica 34, -! pp. 541-551. -! 4. hebden, m.d. (1973), an algorithm for minimization using exact -! second derivatives, report t.p. 515, theoretical physics -! div., a.e.r.e. harwell, oxon., england. -! 5. more, j.j. (1978), the levenberg-marquardt algorithm, implemen- -! tation and theory, pp.105-116 of springer lecture notes -! in mathematics no. 630, edited by g.a. watson, springer- -! verlag, berlin and new york. -! 6. more, j.j., and sorensen, d.c. (1981), computing a trust region -! step, technical report anl-81-83, argonne national lab. -! 7. varga, r.s. (1965), minimal gerschgorin sets, pacific j. math. 15, -! pp. 719-729. -! -! *** general *** -! -! coded by david m. gay. -! this subroutine was written in connection with research -! supported by the national science foundation under grants -! mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -! mcs-7906671. -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -! *** local variables *** -! - logical :: restrt - integer :: dggdmx, diag, diag0, dstsav, emax, emin, i, im1, inc, irc,& - j, k, kalim, kamin, k1, lk0, phipin, q, q0, uk0, x - real(kind=8) :: alphak, aki, akk, delta, dst, eps, gtsta, lk,& - oldphi, phi, phimax, phimin, psifac, rad, radsq,& - root, si, sk, sw, t, twopsi, t1, t2, uk, wi -! -! *** constants *** - real(kind=8) :: big, dgxfac !el, epsfac, four, half, kappa, negone, -!el 1 one, p001, six, three, two, zero -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dabs, dmax1, dmin1, dsqrt -!/ -! *** external functions and subroutines *** -! -!el external dotprd, litvmu, livmul, lsqrt, lsvmin, rmdcon, v2norm -!el real(kind=8) :: dotprd, lsvmin, rmdcon, v2norm -! -! *** subscripts for v *** -! -!el integer dgnorm, dstnrm, dst0, epslon, gtstep, stppar, nreduc, -!el 1 phmnfc, phmxfc, preduc, radius, rad0 -!/6 -! data dgnorm/1/, dstnrm/2/, dst0/3/, epslon/19/, gtstep/4/, -! 1 nreduc/6/, phmnfc/20/, phmxfc/21/, preduc/7/, radius/8/, -! 2 rad0/9/, stppar/5/ -!/7 - integer,parameter :: dgnorm=1, dstnrm=2, dst0=3, epslon=19, gtstep=4,& - nreduc=6, phmnfc=20, phmxfc=21, preduc=7, radius=8,& - rad0=9, stppar=5 -!/ -! -!/6 -! data epsfac/50.0d+0/, four/4.0d+0/, half/0.5d+0/, -! 1 kappa/2.0d+0/, negone/-1.0d+0/, one/1.0d+0/, p001/1.0d-3/, -! 2 six/6.0d+0/, three/3.0d+0/, two/2.0d+0/, zero/0.0d+0/ -!/7 - real(kind=8), parameter :: epsfac=50.0d+0, four=4.0d+0, half=0.5d+0,& - kappa=2.0d+0, negone=-1.0d+0, one=1.0d+0, p001=1.0d-3,& - six=6.0d+0, three=3.0d+0, two=2.0d+0, zero=0.0d+0 - save dgxfac -!/ - data big/0.d+0/, dgxfac/0.d+0/ -! -! *** body *** -! -! *** store largest abs. entry in (d**-1)*h*(d**-1) at w(dggdmx). - dggdmx = p + 1 -! *** store gerschgorin over- and underestimates of the largest -! *** and smallest eigenvalues of (d**-1)*h*(d**-1) at w(emax) -! *** and w(emin) respectively. - emax = dggdmx + 1 - emin = emax + 1 -! *** for use in recomputing step, the final values of lk, uk, dst, -! *** and the inverse derivative of more*s phi at 0 (for pos. def. -! *** h) are stored in w(lk0), w(uk0), w(dstsav), and w(phipin) -! *** respectively. - lk0 = emin + 1 - phipin = lk0 + 1 - uk0 = phipin + 1 - dstsav = uk0 + 1 -! *** store diag of (d**-1)*h*(d**-1) in w(diag),...,w(diag0+p). - diag0 = dstsav - diag = diag0 + 1 -! *** store -d*step in w(q),...,w(q0+p). - q0 = diag0 + p - q = q0 + 1 -! *** allocate storage for scratch vector x *** - x = q + p - rad = v(radius) - radsq = rad**2 -! *** phitol = max. error allowed in dst = v(dstnrm) = 2-norm of -! *** d*step. - phimax = v(phmxfc) * rad - phimin = v(phmnfc) * rad - psifac = two * v(epslon) / (three * (four * (v(phmnfc) + one) * & - (kappa + one) + kappa + two) * rad**2) -! *** oldphi is used to detect limits of numerical accuracy. if -! *** we recompute step and it does not change, then we accept it. - oldphi = zero - eps = v(epslon) - irc = 0 - restrt = .false. - kalim = ka + 50 -! -! *** start or restart, depending on ka *** -! - if (ka .ge. 0) go to 290 -! -! *** fresh start *** -! - k = 0 - uk = negone - ka = 0 - kalim = 50 - v(dgnorm) = v2norm(p, dig) - v(nreduc) = zero - v(dst0) = zero - kamin = 3 - if (v(dgnorm) .eq. zero) kamin = 0 -! -! *** store diag(dihdi) in w(diag0+1),...,w(diag0+p) *** -! - j = 0 - do 10 i = 1, p - j = j + i - k1 = diag0 + i - w(k1) = dihdi(j) - 10 continue -! -! *** determine w(dggdmx), the largest element of dihdi *** -! - t1 = zero - j = p * (p + 1) / 2 - do 20 i = 1, j - t = dabs(dihdi(i)) - if (t1 .lt. t) t1 = t - 20 continue - w(dggdmx) = t1 -! -! *** try alpha = 0 *** -! - 30 call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 50 -! *** indef. h -- underestimate smallest eigenvalue, use this -! *** estimate to initialize lower bound lk on alpha. - j = irc*(irc+1)/2 - t = l(j) - l(j) = one - do 40 i = 1, irc - 40 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = -t / t1 / t1 - v(dst0) = -lk - if (restrt) go to 210 - go to 70 -! -! *** positive definite h -- compute unmodified newton step. *** - 50 lk = zero - t = lsvmin(p, l, w(q), w(q)) - if (t .ge. one) go to 60 - if (big .le. zero) big = rmdcon(6) - if (v(dgnorm) .ge. t*t*big) go to 70 - 60 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - v(nreduc) = half * gtsta - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - v(dst0) = dst - phi = dst - rad - if (phi .le. phimax) go to 260 - if (restrt) go to 210 -! -! *** prepare to compute gerschgorin estimates of largest (and -! *** smallest) eigenvalues. *** -! - 70 k = 0 - do 100 i = 1, p - wi = zero - if (i .eq. 1) go to 90 - im1 = i - 1 - do 80 j = 1, im1 - k = k + 1 - t = dabs(dihdi(k)) - wi = wi + t - w(j) = w(j) + t - 80 continue - 90 w(i) = wi - k = k + 1 - 100 continue -! -! *** (under-)estimate smallest eigenvalue of (d**-1)*h*(d**-1) *** -! - k = 1 - t1 = w(diag) - w(1) - if (p .le. 1) go to 120 - do 110 i = 2, p - j = diag0 + i - t = w(j) - w(i) - if (t .ge. t1) go to 110 - t1 = t - k = i - 110 continue -! - 120 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 150 i = 1, p - if (i .eq. k) go to 130 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (akk - w(j) + si - aki) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 140 - 130 inc = i - 140 k1 = k1 + inc - 150 continue -! - w(emin) = akk - t - uk = v(dgnorm)/rad - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 -! -! *** compute gerschgorin (over-)estimate of largest eigenvalue *** -! - k = 1 - t1 = w(diag) + w(1) - if (p .le. 1) go to 170 - do 160 i = 2, p - j = diag0 + i - t = w(j) + w(i) - if (t .le. t1) go to 160 - t1 = t - k = i - 160 continue -! - 170 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 200 i = 1, p - if (i .eq. k) go to 180 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (w(j) + si - aki - akk) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 190 - 180 inc = i - 190 k1 = k1 + inc - 200 continue -! - w(emax) = akk + t - lk = dmax1(lk, v(dgnorm)/rad - w(emax)) -! -! *** alphak = current value of alpha (see alg. notes above). we -! *** use more*s scheme for initializing it. - alphak = dabs(v(stppar)) * v(rad0)/rad -! - if (irc .ne. 0) go to 210 -! -! *** compute l0 for positive definite h *** -! - call livmul(p, w, l, w(q)) - t = v2norm(p, w) - w(phipin) = dst / t / t - lk = dmax1(lk, phi*w(phipin)) -! -! *** safeguard alphak and add alphak*i to (d**-1)*h*(d**-1) *** -! - 210 ka = ka + 1 - if (-v(dst0) .ge. alphak .or. alphak .lt. lk .or. alphak .ge. uk) & - alphak = uk * dmax1(p001, dsqrt(lk/uk)) - if (alphak .le. zero) alphak = half * uk - if (alphak .le. zero) alphak = uk - k = 0 - do 220 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) + alphak - 220 continue -! -! *** try computing cholesky decomposition *** -! - call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 240 -! -! *** (d**-1)*h*(d**-1) + alphak*i is indefinite -- overestimate -! *** smallest eigenvalue for use in updating lk *** -! - j = (irc*(irc+1))/2 - t = l(j) - l(j) = one - do 230 i = 1, irc - 230 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = alphak - t/t1/t1 - v(dst0) = -lk - go to 210 -! -! *** alphak makes (d**-1)*h*(d**-1) positive definite. -! *** compute q = -d*step, check for convergence. *** -! - 240 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - phi = dst - rad - if (phi .le. phimax .and. phi .ge. phimin) go to 270 - if (phi .eq. oldphi) go to 270 - oldphi = phi - if (phi .lt. zero) go to 330 -! -! *** unacceptable alphak -- update lk, uk, alphak *** -! - 250 if (ka .ge. kalim) go to 270 -! *** the following dmin1 is necessary because of restarts *** - if (phi .lt. zero) uk = dmin1(uk, alphak) -! *** kamin = 0 only iff the gradient vanishes *** - if (kamin .eq. 0) go to 210 - call livmul(p, w, l, w(q)) - t1 = v2norm(p, w) - alphak = alphak + (phi/t1) * (dst/t1) * (dst/rad) - lk = dmax1(lk, alphak) - go to 210 -! -! *** acceptable step on first try *** -! - 260 alphak = zero -! -! *** successful step in general. compute step = -(d**-1)*q *** -! - 270 do 280 i = 1, p - j = q0 + i - step(i) = -w(j)/d(i) - 280 continue - v(gtstep) = -gtsta - v(preduc) = half * (dabs(alphak)*dst*dst + gtsta) - go to 410 -! -! -! *** restart with new radius *** -! - 290 if (v(dst0) .le. zero .or. v(dst0) - rad .gt. phimax) go to 310 -! -! *** prepare to return newton step *** -! - restrt = .true. - ka = ka + 1 - k = 0 - do 300 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) - 300 continue - uk = negone - go to 30 -! - 310 kamin = ka + 3 - if (v(dgnorm) .eq. zero) kamin = 0 - if (ka .eq. 0) go to 50 -! - dst = w(dstsav) - alphak = dabs(v(stppar)) - phi = dst - rad - t = v(dgnorm)/rad - uk = t - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 - if (rad .gt. v(rad0)) go to 320 -! -! *** smaller radius *** - lk = zero - if (alphak .gt. zero) lk = w(lk0) - lk = dmax1(lk, t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -! -! *** bigger radius *** - 320 if (alphak .gt. zero) uk = dmin1(uk, w(uk0)) - lk = dmax1(zero, -v(dst0), t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -! -! *** decide whether to check for special case... in practice (from -! *** the standpoint of the calling optimization code) it seems best -! *** not to check until a few iterations have failed -- hence the -! *** test on kamin below. -! - 330 delta = alphak + dmin1(zero, v(dst0)) - twopsi = alphak*dst*dst + gtsta - if (ka .ge. kamin) go to 340 -! *** if the test in ref. 2 is satisfied, fall through to handle -! *** the special case (as soon as the more-sorensen test detects -! *** it). - if (delta .ge. psifac*twopsi) go to 370 -! -! *** check for the special case of h + alpha*d**2 (nearly) -! *** singular. use one step of inverse power method with start -! *** from lsvmin to obtain approximate eigenvector corresponding -! *** to smallest eigenvalue of (d**-1)*h*(d**-1). lsvmin returns -! *** x and w with l*w = x. -! - 340 t = lsvmin(p, l, w(x), w) -! -! *** normalize w *** - do 350 i = 1, p - 350 w(i) = t*w(i) -! *** complete current inv. power iter. -- replace w by (l**-t)*w. - call litvmu(p, w, l, w) - t2 = one/v2norm(p, w) - do 360 i = 1, p - 360 w(i) = t2*w(i) - t = t2 * t -! -! *** now w is the desired approximate (unit) eigenvector and -! *** t*x = ((d**-1)*h*(d**-1) + alphak*i)*w. -! - sw = dotprd(p, w(q), w) - t1 = (rad + dst) * (rad - dst) - root = dsqrt(sw*sw + t1) - if (sw .lt. zero) root = -root - si = t1 / (sw + root) -! -! *** the actual test for the special case... -! - if ((t2*si)**2 .le. eps*(dst**2 + alphak*radsq)) go to 380 -! -! *** update upper bound on smallest eigenvalue (when not positive) -! *** (as recommended by more and sorensen) and continue... -! - if (v(dst0) .le. zero) v(dst0) = dmin1(v(dst0), t2**2 - alphak) - lk = dmax1(lk, -v(dst0)) -! -! *** check whether we can hope to detect the special case in -! *** the available arithmetic. accept step as it is if not. -! -! *** if not yet available, obtain machine dependent value dgxfac. - 370 if (dgxfac .eq. zero) dgxfac = epsfac * rmdcon(3) -! - if (delta .gt. dgxfac*w(dggdmx)) go to 250 - go to 270 -! -! *** special case detected... negate alphak to indicate special case -! - 380 alphak = -alphak - v(preduc) = half * twopsi -! -! *** accept current step if adding si*w would lead to a -! *** further relative reduction in psi of less than v(epslon)/3. -! - t1 = zero - t = si*(alphak*sw - half*si*(alphak + t*dotprd(p,w(x),w))) - if (t .lt. eps*twopsi/six) go to 390 - v(preduc) = v(preduc) + t - dst = rad - t1 = -si - 390 do 400 i = 1, p - j = q0 + i - w(j) = t1*w(i) - w(j) - step(i) = w(j) / d(i) - 400 continue - v(gtstep) = dotprd(p, dig, w(q)) -! -! *** save values for use in a possible restart *** -! - 410 v(dstnrm) = dst - v(stppar) = alphak - w(lk0) = lk - w(uk0) = uk - v(rad0) = rad - w(dstsav) = dst -! -! *** restore diagonal of dihdi *** -! - j = 0 - do 420 i = 1, p - j = j + i - k = diag0 + i - dihdi(j) = w(k) - 420 continue -! - 999 return -! -! *** last card of gqtst follows *** - end subroutine gqtst -!----------------------------------------------------------------------------- - subroutine lsqrt(n1, n, l, a, irc) -! -! *** compute rows n1 through n of the cholesky factor l of -! *** a = l*(l**t), where l and the lower triangle of a are both -! *** stored compactly by rows (and may occupy the same storage). -! *** irc = 0 means all went well. irc = j means the leading -! *** principal j x j submatrix of a is not positive definite -- -! *** and l(j*(j+1)/2) contains the (nonpos.) reduced j-th diagonal. -! -! *** parameters *** -! - integer :: n1, n, irc -!al real(kind=8) :: l(1), a(1) - real(kind=8) :: l(n*(n+1)/2), a(n*(n+1)/2) -! dimension l(n*(n+1)/2), a(n*(n+1)/2) -! -! *** local variables *** -! - integer :: i, ij, ik, im1, i0, j, jk, jm1, j0, k - real(kind=8) :: t, td !el, zero -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dsqrt -!/ -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -! -! *** body *** -! - i0 = n1 * (n1 - 1) / 2 - do 50 i = n1, n - td = zero - if (i .eq. 1) go to 40 - j0 = 0 - im1 = i - 1 - do 30 j = 1, im1 - t = zero - if (j .eq. 1) go to 20 - jm1 = j - 1 - do 10 k = 1, jm1 - ik = i0 + k - jk = j0 + k - t = t + l(ik)*l(jk) - 10 continue - 20 ij = i0 + j - j0 = j0 + j - t = (a(ij) - t) / l(j0) - l(ij) = t - td = td + t*t - 30 continue - 40 i0 = i0 + i - t = a(i0) - td - if (t .le. zero) go to 60 - l(i0) = dsqrt(t) - 50 continue -! - irc = 0 - go to 999 -! - 60 l(i0) = t - irc = i -! - 999 return -! -! *** last card of lsqrt *** - end subroutine lsqrt -!----------------------------------------------------------------------------- - real(kind=8) function lsvmin(p, l, x, y) -! -! *** estimate smallest sing. value of packed lower triang. matrix l -! -! *** parameter declarations *** -! - integer :: p -!al real(kind=8) :: l(1), x(p), y(p) - real(kind=8) :: l(p*(p+1)/2), x(p), y(p) -! dimension l(p*(p+1)/2) -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -! *** purpose *** -! -! this function returns a good over-estimate of the smallest -! singular value of the packed lower triangular matrix l. -! -! *** parameter description *** -! -! p (in) = the order of l. l is a p x p lower triangular matrix. -! l (in) = array holding the elements of l in row order, i.e. -! l(1,1), l(2,1), l(2,2), l(3,1), l(3,2), l(3,3), etc. -! x (out) if lsvmin returns a positive value, then x is a normalized -! approximate left singular vector corresponding to the -! smallest singular value. this approximation may be very -! crude. if lsvmin returns zero, then some components of x -! are zero and the rest retain their input values. -! y (out) if lsvmin returns a positive value, then y = (l**-1)*x is an -! unnormalized approximate right singular vector correspond- -! ing to the smallest singular value. this approximation -! may be crude. if lsvmin returns zero, then y retains its -! input value. the caller may pass the same vector for x -! and y (nonstandard fortran usage), in which case y over- -! writes x (for nonzero lsvmin returns). -! -! *** algorithm notes *** -! -! the algorithm is based on (1), with the additional provision that -! lsvmin = 0 is returned if the smallest diagonal element of l -! (in magnitude) is not more than the unit roundoff times the -! largest. the algorithm uses a random number generator proposed -! in (4), which passes the spectral test with flying colors -- see -! (2) and (3). -! -! *** subroutines and functions called *** -! -! v2norm - function, returns the 2-norm of a vector. -! -! *** references *** -! -! (1) cline, a., moler, c., stewart, g., and wilkinson, j.h.(1977), -! an estimate for the condition number of a matrix, report -! tm-310, applied math. div., argonne national laboratory. -! -! (2) hoaglin, d.c. (1976), theoretical properties of congruential -! random-number generators -- an empirical view, -! memorandum ns-340, dept. of statistics, harvard univ. -! -! (3) knuth, d.e. (1969), the art of computer programming, vol. 2 -! (seminumerical algorithms), addison-wesley, reading, mass. -! -! (4) smith, c.s. (1971), multiplicative pseudo-random number -! generators with prime modulus, j. assoc. comput. mach. 18, -! pp. 586-593. -! -! *** history *** -! -! designed and coded by david m. gay (winter 1977/summer 1978). -! -! *** general *** -! -! this subroutine was written in connection with research -! supported by the national science foundation under grants -! mcs-7600324, dcr75-10143, 76-14311dss, and mcs76-11989. -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -! *** local variables *** -! - integer :: i, ii, ix, j, ji, jj, jjj, jm1, j0, pm1 - real(kind=8) :: b, sminus, splus, t, xminus, xplus -! -! *** constants *** -! -!el real(kind=8) :: half, one, r9973, zero -! -! *** intrinsic functions *** -!/+ -!el integer mod -!el real float -!el real(kind=8) :: dabs -!/ -! *** external functions and subroutines *** -! -!el external dotprd, v2norm, vaxpy -!el real(kind=8) :: dotprd, v2norm -! -!/6 -! data half/0.5d+0/, one/1.d+0/, r9973/9973.d+0/, zero/0.d+0/ -!/7 - real(kind=8),parameter :: half=0.5d+0, one=1.d+0, r9973=9973.d+0, zero=0.d+0 -!/ -! -! *** body *** -! - ix = 2 - pm1 = p - 1 -! -! *** first check whether to return lsvmin = 0 and initialize x *** -! - ii = 0 - j0 = p*pm1/2 - jj = j0 + p - if (l(jj) .eq. zero) go to 110 - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = b / l(jj) - x(p) = xplus - if (p .le. 1) go to 60 - do 10 i = 1, pm1 - ii = ii + i - if (l(ii) .eq. zero) go to 110 - ji = j0 + i - x(i) = xplus * l(ji) - 10 continue -! -! *** solve (l**t)*x = b, where the components of b have randomly -! *** chosen magnitudes in (.5,1) with signs chosen to make x large. -! -! do j = p-1 to 1 by -1... - do 50 jjj = 1, pm1 - j = p - jjj -! *** determine x(j) in this iteration. note for i = 1,2,...,j -! *** that x(i) holds the current partial sum for row i. - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = (b - x(j)) - xminus = (-b - x(j)) - splus = dabs(xplus) - sminus = dabs(xminus) - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - xplus = xplus/l(jj) - xminus = xminus/l(jj) - if (jm1 .eq. 0) go to 30 - do 20 i = 1, jm1 - ji = j0 + i - splus = splus + dabs(x(i) + l(ji)*xplus) - sminus = sminus + dabs(x(i) + l(ji)*xminus) - 20 continue - 30 if (sminus .gt. splus) xplus = xminus - x(j) = xplus -! *** update partial sums *** - if (jm1 .gt. 0) call vaxpy(jm1, x, xplus, l(j0+1), x) - 50 continue -! -! *** normalize x *** -! - 60 t = one/v2norm(p, x) - do 70 i = 1, p - 70 x(i) = t*x(i) -! -! *** solve l*y = x and return lsvmin = 1/twonorm(y) *** -! - do 100 j = 1, p - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - t = zero - if (jm1 .gt. 0) t = dotprd(jm1, l(j0+1), y) - y(j) = (x(j) - t) / l(jj) - 100 continue -! - lsvmin = one/v2norm(p, y) - go to 999 -! - 110 lsvmin = zero - 999 return -! *** last card of lsvmin follows *** - end function lsvmin -!----------------------------------------------------------------------------- - subroutine slvmul(p, y, s, x) -! -! *** set y = s * x, s = p x p symmetric matrix. *** -! *** lower triangle of s stored rowwise. *** -! -! *** parameter declarations *** -! - integer :: p -!al real(kind=8) :: s(1), x(p), y(p) - real(kind=8) :: s(p*(p+1)/2), x(p), y(p) -! dimension s(p*(p+1)/2) -! -! *** local variables *** -! - integer :: i, im1, j, k - real(kind=8) :: xi -! -! *** no intrinsic functions *** -! -! *** external function *** -! -!el external dotprd -!el real(kind=8) :: dotprd -! -!----------------------------------------------------------------------- -! - j = 1 - do 10 i = 1, p - y(i) = dotprd(i, s(j), x) - j = j + i - 10 continue -! - if (p .le. 1) go to 999 - j = 1 - do 40 i = 2, p - xi = x(i) - im1 = i - 1 - j = j + 1 - do 30 k = 1, im1 - y(k) = y(k) + s(j)*xi - j = j + 1 - 30 continue - 40 continue -! - 999 return -! *** last card of slvmul follows *** - end subroutine slvmul -!----------------------------------------------------------------------------- -! minimize_p.F -!----------------------------------------------------------------------------- - subroutine minimize(etot,x,iretcode,nfun) - - use energy, only: func,gradient,fdum!,etotal,enerprint - use comm_srutu -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer,parameter :: liv=60 -! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) -!******************************************************************** -! OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * -! the calling subprogram. * -! when d(i)=1.0, then v(35) is the length of the initial step, * -! calculated in the usual pythagorean way. * -! absolute convergence occurs when the function is within v(31) of * -! zero. unless you know the minimum value in advance, abs convg * -! is probably not useful. * -! relative convergence is when the model predicts that the function * -! will decrease by less than v(32)*abs(fun). * -!******************************************************************** -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.MINIM' - integer :: i -!el common /srutu/ icall - integer,dimension(liv) :: iv - real(kind=8) :: minval !,v(1:77+(6*nres)*(6*nres+17)/2) !(1:lv) -!el real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) - real(kind=8) :: energia(0:n_ene) -! external func,gradient,fdum -! external func_restr,grad_restr - logical :: not_done,change,reduce -!el common /przechowalnia/ v -!el local variables - integer :: iretcode,nfun,lv,nvar_restr,idum(1),j - real(kind=8) :: etot,rdum(1) !,fdum - - lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) - - if (.not.allocated(v)) allocate(v(1:lv)) - - icall = 1 - - NOT_DONE=.TRUE. - -! DO WHILE (NOT_DONE) - - call deflt(2,iv,liv,lv,v) -! 12 means fresh start, dont call deflt - iv(1)=12 -! max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -! max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -! controls output - iv(19)=2 -! selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -! 1 means to print out result - iv(22)=print_min_res -! 1 means to print out summary stats - iv(23)=print_min_stat -! 1 means to print initial x and d - iv(24)=print_min_ini -! min val for v(radfac) default is 0.1 - v(24)=0.1D0 -! max val for v(radfac) default is 4.0 - v(25)=2.0D0 -! v(25)=4.0D0 -! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -! the sumsl default is 0.1 - v(26)=0.1D0 -! false conv if (act fnctn decrease) .lt. v(34) -! the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -! absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -! relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -! controls initial step size - v(35)=1.0D-1 -! large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -!d print *,'Calling SUMSL' -! call var_to_geom(nvar,x) -! call chainbuild -! call etotal(energia(0)) -! etot = energia(0) -!elmask_r=.true. - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr,grad_restr,& - iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) -!d print *,'Exit SUMSL; return code:',iretcode,' energy:',etot -!d write (iout,'(/a,i4/)') 'SUMSL return code:',iv(1) -! call intout -! change=reduce(x) - call var_to_geom(nvar,x) -! if (change) then -! write (iout,'(a)') 'Reduction worked, minimizing again...' -! else -! not_done=.false. -! endif - call chainbuild - -!el--------------------- -! write (iout,'(/a)') & -! "Cartesian coordinates of the reference structure after SUMSL" -! write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & -! "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" -! do i=1,nres -! write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & -! restyp(itype(i)),i,(c(j,i),j=1,3),& -! (c(j,i+nres),j=1,3) -! enddo -!el---------------------------- -! call etotal(energia) !sp -! etot=energia(0) -! call enerprint(energia) !sp - nfun=iv(6) - -! write (*,*) 'Processor',MyID,' leaves MINIMIZE.' - -! ENDDO ! NOT_DONE - - return - end subroutine minimize -!----------------------------------------------------------------------------- -! gradient_p.F -!----------------------------------------------------------------------------- - subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) - - use energy, only: cartder,zerograd,etotal,sum_gradient -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -!EL external ufparm - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) - integer :: n,nf,ig,ind,i,j,ij,k,igall - real(kind=8) :: f,gphii,gthetai,galphai,gomegai - real(kind=8),external :: ufparm - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) -! write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 continue -#ifdef OSF -! Intercept NaNs in the coordinates -! write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** grad_restr : Found NaN in coordinates" - call flush(iout) - print *," *** grad_restr : Found NaN in coordinates" - return - endif -#endif - call var_to_geom_restr(n,x) - call chainbuild -! -! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -! - 40 call cartder -! -! Convert the Cartesian gradient into internal-coordinate gradient. -! - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -! -! Add the components corresponding to local energy terms. -! - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -!d do i=1,ig -!d write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -!d enddo - return - end subroutine grad_restr -!----------------------------------------------------------------------------- - subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F - - use comm_chu - use energy, only: zerograd,etotal,sum_gradient -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' - integer :: n,nf -!el integer :: jjj -!el common /chuju/ jjj - real(kind=8) :: energia(0:n_ene) - real(kind=8) :: f - real(kind=8),external :: ufparm - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) -! if (jjj.gt.0) then -! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -! endif - nfl=nf - icg=mod(nf,2)+1 - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -!d write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia) - call sum_gradient - f=energia(0) -! if (jjj.gt.0) then -! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -! write (iout,*) 'f=',etot -! jjj=0 -! endif - return - end subroutine func_restr -!----------------------------------------------------------------------------- -! subroutine func(n,x,nf,f,uiparm,urparm,ufparm) in module energy -!----------------------------------------------------------------------------- - subroutine x2xx(x,xx,n) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' - integer :: n,i,ij,ig,igall - real(kind=8),dimension(6*nres) :: xx,x !(maxvar) (maxvar=6*maxres) - -!el allocate(varall(nvar)) allocated in alioc_ener_arrays - - do i=1,nvar - varall(i)=x(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - endif - enddo - enddo - - n=ig - - return - end subroutine x2xx -!----------------------------------------------------------------------------- -!el subroutine xx2x(x,xx) in module math -!----------------------------------------------------------------------------- - subroutine minim_dc(etot,iretcode,nfun) - - use MPI_data - use energy, only: fdum,check_ecartint -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - integer,parameter :: liv=60 -! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.MINIM' -! include 'COMMON.CHAIN' - integer :: iretcode,nfun,k,i,j,lv,idum(1) - integer,dimension(liv) :: iv - real(kind=8) :: minval !,v(1:77+(6*nres)*(6*nres+17)/2) !(1:lv) - real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) -!el common /przechowalnia/ v - - real(kind=8) :: energia(0:n_ene) -! external func_dc,grad_dc ,fdum - logical :: not_done,change,reduce - real(kind=8) :: g(6*nres),f1,etot,rdum(1) !,fdum - - lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) - - if (.not. allocated(v)) allocate(v(1:lv)) - - call deflt(2,iv,liv,lv,v) -! 12 means fresh start, dont call deflt - iv(1)=12 -! max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -! max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -! controls output - iv(19)=2 -! selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -! 1 means to print out result - iv(22)=print_min_res -! 1 means to print out summary stats - iv(23)=print_min_stat -! 1 means to print initial x and d - iv(24)=print_min_ini -! min val for v(radfac) default is 0.1 - v(24)=0.1D0 -! max val for v(radfac) default is 4.0 - v(25)=2.0D0 -! v(25)=4.0D0 -! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -! the sumsl default is 0.1 - v(26)=0.1D0 -! false conv if (act fnctn decrease) .lt. v(34) -! the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -! absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -! relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -! controls initial step size - v(35)=1.0D-1 -! large vals of d correspond to small components of step - do i=1,6*nres - d(i)=1.0D-1 - enddo - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - x(k)=dc(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - x(k)=dc(j,i+nres) - enddo - endif - enddo - call check_ecartint - call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum) - call check_ecartint - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -!d call zerograd -!d nf=0 -!d call func_dc(k,x,nf,f,idum,rdum,fdum) -!d call grad_dc(k,x,nf,g,idum,rdum,fdum) -!d -!d do i=1,k -!d x(i)=x(i)+1.0D-5 -!d call func_dc(k,x,nf,f1,idum,rdum,fdum) -!d x(i)=x(i)-1.0D-5 -!d print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 -!d enddo -!el--------------------- -! write (iout,'(/a)') & -! "Cartesian coordinates of the reference structure after SUMSL" -! write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & -! "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" -! do i=1,nres -! write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & -! restyp(itype(i)),i,(c(j,i),j=1,3),& -! (c(j,i+nres),j=1,3) -! enddo -!el---------------------------- - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - return - end subroutine minim_dc -!----------------------------------------------------------------------------- - subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) - - use MPI_data - use energy, only: zerograd,etotal -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' - integer :: n,nf,k,i,j - real(kind=8) :: energia(0:n_ene) - real(kind=8),external :: ufparm - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) - real(kind=8) :: f - nfl=nf -!bad icg=mod(nf,2)+1 - icg=1 - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - - call zerograd - call etotal(energia) - f=energia(0) - -!d print *,'func_dc ',nf,nfl,f - - return - end subroutine func_dc -!----------------------------------------------------------------------------- - subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm) - - use MPI_data - use energy, only: cartgrad,zerograd,etotal -! use MD_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.SETUP' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' - real(kind=8),external :: ufparm - integer :: n,nf,i,j,k - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) - real(kind=8) :: f -! -!elwrite(iout,*) "jestesmy w grad dc" -! -!bad icg=mod(nf,2)+1 - icg=1 -!d print *,'grad_dc ',nf,nfl,nf-nfl+1,icg -!elwrite(iout,*) "jestesmy w grad dc nf-nfl+1", nf-nfl+1 - if (nf-nfl+1) 20,30,40 - 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm) -!d print *,20 - if (nf.eq.0) return - goto 40 - 30 continue -!d print *,30 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo -!elwrite(iout,*) "jestesmy w grad dc" - call chainbuild_cart - -! -! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -! - 40 call cartgrad -!d print *,40 -!elwrite(iout,*) "jestesmy w grad dc" - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - g(k)=gcart(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - g(k)=gxcart(j,i) - enddo - endif - enddo -!elwrite(iout,*) "jestesmy w grad dc" - - return - end subroutine grad_dc -!----------------------------------------------------------------------------- -! minim_mcmf.F -!----------------------------------------------------------------------------- -#ifdef MPI - subroutine minim_mcmf - - use MPI_data - use csa_data - use energy, only: func,gradient,fdum -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' - integer,parameter :: liv=60 -! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.MINIM' -! real(kind=8) :: fdum -! external func,gradient,fdum -!el real(kind=4) :: ran1,ran2,ran3 -! include 'COMMON.SETUP' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) - real(kind=8),dimension(mxch*(mxch+1)/2+1) :: erg - real(kind=8),dimension(6*nres) :: d,garbage !(maxvar) (maxvar=6*maxres) -!el real(kind=8) :: v(1:77+(6*nres)*(6*nres+17)/2+1) - integer,dimension(6) :: indx - integer,dimension(liv) :: iv - integer :: lv,idum(1),nf ! - real(kind=8) :: rdum(1) - real(kind=8) :: przes(3),obrot(3,3),eee - logical :: non_conv - - integer,dimension(MPI_STATUS_SIZE) :: muster - - integer :: ichuj,i,ierr - real(kind=8) :: rad,ene0 - data rad /1.745329252d-2/ -!el common /przechowalnia/ v - - lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) - if (.not. allocated(v)) allocate(v(1:lv)) - - ichuj=0 - 10 continue - ichuj = ichuj + 1 - call mpi_recv(indx,6,mpi_integer,king,idint,CG_COMM,& - muster,ierr) - if (indx(1).eq.0) return -! print *, 'worker ',me,' received order ',n,ichuj - call mpi_recv(var,nvar,mpi_double_precision,& - king,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene0,1,mpi_double_precision,& - king,idreal,CG_COMM,muster,ierr) -! print *, 'worker ',me,' var read ' - - - call deflt(2,iv,liv,lv,v) -! 12 means fresh start, dont call deflt - iv(1)=12 -! max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -! max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -! controls output - iv(19)=2 -! selects output unit -! iv(21)=iout - iv(21)=0 -! 1 means to print out result - iv(22)=0 -! 1 means to print out summary stats - iv(23)=0 -! 1 means to print initial x and d - iv(24)=0 -! min val for v(radfac) default is 0.1 - v(24)=0.1D0 -! max val for v(radfac) default is 4.0 - v(25)=2.0D0 -! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -! the sumsl default is 0.1 - v(26)=0.1D0 -! false conv if (act fnctn decrease) .lt. v(34) -! the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -! absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -! relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -! controls initial step size - v(35)=1.0D-1 -! large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -! minimize energy - - call func(nvar,var,nf,eee,idum,rdum,fdum) - if(eee.gt.1.0d18) then -! print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' -! print *,' energy before SUMSL =',eee -! print *,' aborting local minimization' - iv(1)=-1 - v(10)=eee - nf=1 - go to 201 - endif - - call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) -! find which conformation was returned from sumsl - nf=iv(7)+1 - 201 continue -! total # of ftn evaluations (for iwf=0, it includes all minimizations). - indx(4)=nf - indx(5)=iv(1) - eee=v(10) - - call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM,& - ierr) -! print '(a5,i3,15f10.5)', 'ENEX0',indx(1),v(10) - call mpi_send(var,nvar,mpi_double_precision,& - king,idreal,CG_COMM,ierr) - call mpi_send(eee,1,mpi_double_precision,king,idreal,& - CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,king,idreal,& - CG_COMM,ierr) - go to 10 - return - end subroutine minim_mcmf -#endif -!----------------------------------------------------------------------------- -! rmdd.f -!----------------------------------------------------------------------------- -! algorithm 611, collected algorithms from acm. -! algorithm appeared in acm-trans. math. software, vol.9, no. 4, -! dec., 1983, p. 503-524. - integer function imdcon(k) -! - integer :: k -! -! *** return integer machine-dependent constants *** -! -! *** k = 1 means return standard output unit number. *** -! *** k = 2 means return alternate output unit number. *** -! *** k = 3 means return input unit number. *** -! (note -- k = 2, 3 are used only by test programs.) -! -! +++ port version follows... -! external i1mach -! integer i1mach -! integer mdperm(3) -! data mdperm(1)/2/, mdperm(2)/4/, mdperm(3)/1/ -! imdcon = i1mach(mdperm(k)) -! +++ end of port version +++ -! -! +++ non-port version follows... - integer :: mdcon(3) - data mdcon(1)/6/, mdcon(2)/8/, mdcon(3)/5/ - imdcon = mdcon(k) -! +++ end of non-port version +++ -! - 999 return -! *** last card of imdcon follows *** - end function imdcon -!----------------------------------------------------------------------------- - real(kind=8) function rmdcon(k) -! -! *** return machine dependent constants used by nl2sol *** -! -! +++ comments below contain data statements for various machines. +++ -! +++ to convert to another machine, place a c in column 1 of the +++ -! +++ data statement line(s) that correspond to the current machine +++ -! +++ and remove the c from column 1 of the data statement line(s) +++ -! +++ that correspond to the new machine. +++ -! - integer :: k -! -! *** the constant returned depends on k... -! -! *** k = 1... smallest pos. eta such that -eta exists. -! *** k = 2... square root of eta. -! *** k = 3... unit roundoff = smallest pos. no. machep such -! *** that 1 + machep .gt. 1 .and. 1 - machep .lt. 1. -! *** k = 4... square root of machep. -! *** k = 5... square root of big (see k = 6). -! *** k = 6... largest machine no. big such that -big exists. -! - real(kind=8) :: big, eta, machep - integer :: bigi(4), etai(4), machei(4) -!/+ -!el real(kind=8) :: dsqrt -!/ - equivalence (big,bigi(1)), (eta,etai(1)), (machep,machei(1)) -! -! +++ ibm 360, ibm 370, or xerox +++ -! -! data big/z7fffffffffffffff/, eta/z0010000000000000/, -! 1 machep/z3410000000000000/ -! -! +++ data general +++ -! -! data big/0.7237005577d+76/, eta/0.5397605347d-78/, -! 1 machep/2.22044605d-16/ -! -! +++ dec 11 +++ -! -! data big/1.7d+38/, eta/2.938735878d-39/, machep/2.775557562d-17/ -! -! +++ hp3000 +++ -! -! data big/1.157920892d+77/, eta/8.636168556d-78/, -! 1 machep/5.551115124d-17/ -! -! +++ honeywell +++ -! -! data big/1.69d+38/, eta/5.9d-39/, machep/2.1680435d-19/ -! -! +++ dec10 +++ -! -! data big/"377777100000000000000000/, -! 1 eta/"002400400000000000000000/, -! 2 machep/"104400000000000000000000/ -! -! +++ burroughs +++ -! -! data big/o0777777777777777,o7777777777777777/, -! 1 eta/o1771000000000000,o7770000000000000/, -! 2 machep/o1451000000000000,o0000000000000000/ -! -! +++ control data +++ -! -! data big/37767777777777777777b,37167777777777777777b/, -! 1 eta/00014000000000000000b,00000000000000000000b/, -! 2 machep/15614000000000000000b,15010000000000000000b/ -! -! +++ prime +++ -! -! data big/1.0d+9786/, eta/1.0d-9860/, machep/1.4210855d-14/ -! -! +++ univac +++ -! -! data big/8.988d+307/, eta/1.2d-308/, machep/1.734723476d-18/ -! -! +++ vax +++ -! - data big/1.7d+38/, eta/2.939d-39/, machep/1.3877788d-17/ -! -! +++ cray 1 +++ -! -! data bigi(1)/577767777777777777777b/, -! 1 bigi(2)/000007777777777777776b/, -! 2 etai(1)/200004000000000000000b/, -! 3 etai(2)/000000000000000000000b/, -! 4 machei(1)/377224000000000000000b/, -! 5 machei(2)/000000000000000000000b/ -! -! +++ port library -- requires more than just a data statement... +++ -! -! external d1mach -! double precision d1mach, zero -! data big/0.d+0/, eta/0.d+0/, machep/0.d+0/, zero/0.d+0/ -! if (big .gt. zero) go to 1 -! big = d1mach(2) -! eta = d1mach(1) -! machep = d1mach(4) -!1 continue -! -! +++ end of port +++ -! -!------------------------------- body -------------------------------- -! - go to (10, 20, 30, 40, 50, 60), k -! - 10 rmdcon = eta - go to 999 -! - 20 rmdcon = dsqrt(256.d+0*eta)/16.d+0 - go to 999 -! - 30 rmdcon = machep - go to 999 -! - 40 rmdcon = dsqrt(machep) - go to 999 -! - 50 rmdcon = dsqrt(big/256.d+0)*16.d+0 - go to 999 -! - 60 rmdcon = big -! - 999 return -! *** last card of rmdcon follows *** - end function rmdcon -!----------------------------------------------------------------------------- -! sc_move.F -!----------------------------------------------------------------------------- - subroutine sc_move(n_start,n_end,n_maxtry,e_drop,n_fun,etot) - - use control - use random, only: iran_num - use energy, only: esc -! Perform a quick search over side-chain arrangments (over -! residues n_start to n_end) for a given (frozen) CA trace -! Only side-chains are minimized (at most n_maxtry times each), -! not CA positions -! Stops if energy drops by e_drop, otherwise tries all residues -! in the given range -! If there is an energy drop, full minimization may be useful -! n_start, n_end CAN be modified by this routine, but only if -! out of bounds (n_start <= 1, n_end >= nres, n_start < n_end) -! NOTE: this move should never increase the energy -!rc implicit none - -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.HEADER' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' - -! External functions -!el integer iran_num -!el external iran_num - -! Input arguments - integer :: n_start,n_end,n_maxtry - real(kind=8) :: e_drop - -! Output arguments - integer :: n_fun - real(kind=8) :: etot - -! Local variables -! real(kind=8) :: energy(0:n_ene) - real(kind=8) :: cur_alph(2:nres-1),cur_omeg(2:nres-1) - real(kind=8) :: orig_e,cur_e - integer :: n,n_steps,n_first,n_cur,n_tot !,i - real(kind=8) :: orig_w(0:n_ene) - real(kind=8) :: wtime - -!elwrite(iout,*) "in sc_move etot= ", etot -! Set non side-chain weights to zero (minimization is faster) -! NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - orig_w(15)=wvdwpp - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - wvdwpp=0.D0 - -! Make sure n_start, n_end are within proper range - if (n_start.lt.2) n_start=2 - if (n_end.gt.nres-1) n_end=nres-1 -!rc if (n_start.lt.n_end) then - if (n_start.gt.n_end) then - n_start=2 - n_end=nres-1 - endif - -! Save the initial values of energy and coordinates -!d call chainbuild -!d call etotal(energy) -!d write (iout,*) 'start sc ene',energy(0) -!d call enerprint(energy(0)) -!rc etot=energy(0) - n_fun=0 -!rc orig_e=etot -!rc cur_e=orig_e -!rc do i=2,nres-1 -!rc cur_alph(i)=alph(i) -!rc cur_omeg(i)=omeg(i) -!rc enddo - -!t wtime=MPI_WTIME() -! Try (one by one) all specified residues, starting from a -! random position in sequence -! Stop early if the energy has decreased by at least e_drop - n_tot=n_end-n_start+1 - n_first=iran_num(0,n_tot-1) - n_steps=0 - n=0 -!rc do while (n.lt.n_tot .and. orig_e-etot.lt.e_drop) - do while (n.lt.n_tot) - n_cur=n_start+mod(n_first+n,n_tot) - call single_sc_move(n_cur,n_maxtry,e_drop,& - n_steps,n_fun,etot) -!elwrite(iout,*) "after msingle sc_move etot= ", etot -! If a lower energy was found, update the current structure... -!rc if (etot.lt.cur_e) then -!rc cur_e=etot -!rc do i=2,nres-1 -!rc cur_alph(i)=alph(i) -!rc cur_omeg(i)=omeg(i) -!rc enddo -!rc else -! ...else revert to the previous one -!rc etot=cur_e -!rc do i=2,nres-1 -!rc alph(i)=cur_alph(i) -!rc omeg(i)=cur_omeg(i) -!rc enddo -!rc endif - n=n+1 -!d -!d call chainbuild -!d call etotal(energy) -!d print *,'running',n,energy(0) - enddo - -!d call chainbuild -!d call etotal(energy) -!d write (iout,*) 'end sc ene',energy(0) - -! Put the original weights back to calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - wvdwpp=orig_w(15) - -!rc n_fun=n_fun+1 -!t write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime - return - end subroutine sc_move -!----------------------------------------------------------------------------- - subroutine single_sc_move(res_pick,n_maxtry,e_drop,n_steps,n_fun,e_sc) - -! Perturb one side-chain (res_pick) and minimize the -! neighbouring region, keeping all CA's and non-neighbouring -! side-chains fixed -! Try until e_drop energy improvement is achieved, or n_maxtry -! attempts have been made -! At the start, e_sc should contain the side-chain-only energy(0) -! nsteps and nfun for this move are ADDED to n_steps and n_fun -!rc implicit none - use energy, only: esc - use geometry, only:dist -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.CHAIN' -! include 'COMMON.MINIM' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' - -! External functions -!el double precision dist -!el external dist - -! Input arguments - integer :: res_pick,n_maxtry - real(kind=8) :: e_drop - -! Input/Output arguments - integer :: n_steps,n_fun - real(kind=8) :: e_sc - -! Local variables - logical :: fail - integer :: i,j - integer :: nres_moved - integer :: iretcode,loc_nfun,orig_maxfun,n_try - real(kind=8) :: sc_dist,sc_dist_cutoff -! real(kind=8) :: energy_(0:n_ene) - real(kind=8) :: evdw,escloc,orig_e,cur_e - real(kind=8) :: cur_alph(2:nres-1),cur_omeg(2:nres-1) - real(kind=8) :: var(6*nres) !(maxvar) (maxvar=6*maxres) - - real(kind=8) :: orig_theta(1:nres),orig_phi(1:nres),& - orig_alph(1:nres),orig_omeg(1:nres) - -!elwrite(iout,*) "in sinle etot/ e_sc",e_sc -! Define what is meant by "neighbouring side-chain" - sc_dist_cutoff=5.0D0 - -! Don't do glycine or ends - i=itype(res_pick) - if (i.eq.10 .or. i.eq.ntyp1) return - -! Freeze everything (later will relax only selected side-chains) - mask_r=.true. - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=0 - enddo - -! Find the neighbours of the side-chain to move -! and save initial variables -!rc orig_e=e_sc -!rc cur_e=orig_e - nres_moved=0 - do i=2,nres-1 -! Don't do glycine (itype(j)==10) - if (itype(i).ne.10) then - sc_dist=dist(nres+i,nres+res_pick) - else - sc_dist=sc_dist_cutoff - endif - if (sc_dist.lt.sc_dist_cutoff) then - nres_moved=nres_moved+1 - mask_side(i)=1 - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - - call chainbuild - call egb1(evdw) - call esc(escloc) -!elwrite(iout,*) "in sinle etot/ e_sc",e_sc -!elwrite(iout,*) "in sinle wsc=",wsc,"evdw",evdw,"wscloc",wscloc,"escloc",escloc - e_sc=wsc*evdw+wscloc*escloc -!elwrite(iout,*) "in sinle etot/ e_sc",e_sc -!d call etotal(energy) -!d print *,'new ',(energy(k),k=0,n_ene) - orig_e=e_sc - cur_e=orig_e - - n_try=0 - do while (n_try.lt.n_maxtry .and. orig_e-cur_e.lt.e_drop) -! Move the selected residue (don't worry if it fails) - call gen_side(iabs(itype(res_pick)),theta(res_pick+1),& - alph(res_pick),omeg(res_pick),fail) - -! Minimize the side-chains starting from the new arrangement - call geom_to_var(nvar,var) - orig_maxfun=maxfun - maxfun=7 - -!rc do i=1,nres -!rc orig_theta(i)=theta(i) -!rc orig_phi(i)=phi(i) -!rc orig_alph(i)=alph(i) -!rc orig_omeg(i)=omeg(i) -!rc enddo - -!elwrite(iout,*) "in sinle etot/ e_sc",e_sc - call minimize_sc1(e_sc,var,iretcode,loc_nfun) - -!elwrite(iout,*) "in sinle etot/ e_sc",e_sc -!v write(*,'(2i3,2f12.5,2i3)') -!v & res_pick,nres_moved,orig_e,e_sc-cur_e, -!v & iretcode,loc_nfun - -!$$$ if (iretcode.eq.8) then -!$$$ write(iout,*)'Coordinates just after code 8' -!$$$ call chainbuild -!$$$ call all_varout -!$$$ call flush(iout) -!$$$ do i=1,nres -!$$$ theta(i)=orig_theta(i) -!$$$ phi(i)=orig_phi(i) -!$$$ alph(i)=orig_alph(i) -!$$$ omeg(i)=orig_omeg(i) -!$$$ enddo -!$$$ write(iout,*)'Coordinates just before code 8' -!$$$ call chainbuild -!$$$ call all_varout -!$$$ call flush(iout) -!$$$ endif - - n_fun=n_fun+loc_nfun - maxfun=orig_maxfun - call var_to_geom(nvar,var) - -! If a lower energy was found, update the current structure... - if (e_sc.lt.cur_e) then -!v call chainbuild -!v call etotal(energy) -!d call egb1(evdw) -!d call esc(escloc) -!d e_sc1=wsc*evdw+wscloc*escloc -!d print *,' new',e_sc1,energy(0) -!v print *,'new ',energy(0) -!d call enerprint(energy(0)) - cur_e=e_sc - do i=2,nres-1 - if (mask_side(i).eq.1) then - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - else -! ...else revert to the previous one - e_sc=cur_e - do i=2,nres-1 - if (mask_side(i).eq.1) then - alph(i)=cur_alph(i) - omeg(i)=cur_omeg(i) - endif - enddo - endif - n_try=n_try+1 - - enddo - n_steps=n_steps+n_try - -! Reset the minimization mask_r to false - mask_r=.false. - - return - end subroutine single_sc_move -!----------------------------------------------------------------------------- - subroutine sc_minimize(etot,iretcode,nfun) - -! Minimizes side-chains only, leaving backbone frozen -!rc implicit none - use energy, only: etotal -! Includes -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.FFIELD' - -! Output arguments - real(kind=8) :: etot - integer :: iretcode,nfun - -! Local variables - integer :: i - real(kind=8) :: orig_w(0:n_ene),energy_(0:n_ene) - real(kind=8) :: var(6*nres) !(maxvar)(maxvar=6*maxres) - - -! Set non side-chain weights to zero (minimization is faster) -! NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - -! Prepare to freeze backbone - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=1 - enddo - -! Minimize the side-chains - mask_r=.true. - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - call var_to_geom(nvar,var) - mask_r=.false. - -! Put the original weights back and calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - - call chainbuild - call etotal(energy_) - etot=energy_(0) - - return - end subroutine sc_minimize -!----------------------------------------------------------------------------- - subroutine minimize_sc1(etot,x,iretcode,nfun) - - use energy, only: func,gradient,fdum,etotal,enerprint - use comm_srutu -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer,parameter :: liv=60 - integer :: iretcode,nfun -! integer :: lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.MINIM' -!el integer :: icall -!el common /srutu/ icall - integer,dimension(liv) :: iv - real(kind=8) :: minval !,v(1:77+(6*nres)*(6*nres+17)/2) !(1:lv) - real(kind=8),dimension(6*nres) :: x,d,xx !(maxvar) (maxvar=6*maxres) - real(kind=8) :: energia(0:n_ene) -!el real(kind=8) :: fdum -! external gradient,fdum !func, -! external func_restr1,grad_restr1 - logical :: not_done,change,reduce -!el common /przechowalnia/ v - - integer :: nvar_restr,lv,i,j - integer :: idum(1) - real(kind=8) :: rdum(1),etot !,fdum - - lv=(77+(6*nres)*(6*nres+17)/2) !(77+maxvar*(maxvar+17)/2)) (maxvar=6*maxres) - if (.not. allocated(v)) allocate(v(1:lv)) - - call deflt(2,iv,liv,lv,v) -! 12 means fresh start, dont call deflt - iv(1)=12 -! max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -! max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -! controls output - iv(19)=2 -! selects output unit -! iv(21)=iout - iv(21)=0 -! 1 means to print out result - iv(22)=0 -! 1 means to print out summary stats - iv(23)=0 -! 1 means to print initial x and d - iv(24)=0 -! min val for v(radfac) default is 0.1 - v(24)=0.1D0 -! max val for v(radfac) default is 4.0 - v(25)=2.0D0 -! v(25)=4.0D0 -! check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -! the sumsl default is 0.1 - v(26)=0.1D0 -! false conv if (act fnctn decrease) .lt. v(34) -! the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -! absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -! relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -! controls initial step size - v(35)=1.0D-1 -! large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -!elmask_r=.false. - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr1,grad_restr1,& - iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF -!el--------------------- -! write (iout,'(/a)') & -! "Cartesian coordinates of the reference structure after SUMSL" -! write (iout,'(a,3(3x,a5),5x,3(3x,a5))') & -! "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)" -! do i=1,nres -! write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)') & -! restyp(itype(i)),i,(c(j,i),j=1,3),& -! (c(j,i+nres),j=1,3) -! enddo -! call etotal(energia) -! call enerprint(energia) -!el---------------------------- - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - - return - end subroutine minimize_sc1 -!----------------------------------------------------------------------------- - subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) - - use comm_chu - use energy, only: zerograd,esc,sc_grad -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.FFIELD' -! include 'COMMON.INTERACT' -! include 'COMMON.TIME1' - integer :: n,nf,i,j -!el common /chuju/ jjj - real(kind=8) :: energia(0:n_ene),evdw,escloc - real(kind=8) :: e1,e2,f - real(kind=8),external :: ufparm - integer :: uiparm(1) - real(kind=8) :: urparm(1) - real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) - nfl=nf - icg=mod(nf,2)+1 - -#ifdef OSF -! Intercept NaNs in the coordinates, before calling etotal - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - FOUND_NAN=.false. - if (x_sum.ne.x_sum) then - write(iout,*)" *** func_restr1 : Found NaN in coordinates" - f=1.0D+73 - FOUND_NAN=.true. - return - endif -#endif - - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -!d write (iout,*) 'ETOTAL called from FUNC' - call egb1(evdw) - call esc(escloc) - f=wsc*evdw+wscloc*escloc -!d call etotal(energia(0)) -!d f=wsc*energia(1)+wscloc*energia(12) -!d print *,f,evdw,escloc,energia(0) -! -! Sum up the components of the Cartesian gradient. -! - do i=1,nct - do j=1,3 - gradx(j,i,icg)=wsc*gvdwx(j,i) - enddo - enddo - - return - end subroutine func_restr1 -!----------------------------------------------------------------------------- - subroutine grad_restr1(n,x,nf,g,uiparm,urparm,ufparm) - - use energy, only: cartder,zerograd,esc,sc_grad -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -!el external ufparm - integer :: i,j,k,ind,n,nf,uiparm(1) - real(kind=8) :: f,urparm(1) - real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) - integer :: ig,igall,ij - real(kind=8) :: gphii,gthetai,galphai,gomegai - real(kind=8),external :: ufparm - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr1(n,x,nf,f,uiparm,urparm,ufparm) -! write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom_restr(n,x) - call chainbuild -! -! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -! - 40 call cartder -! -! Convert the Cartesian gradient into internal-coordinate gradient. -! - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -! -! Add the components corresponding to local energy terms. -! - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -!d do i=1,ig -!d write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -!d enddo - return - end subroutine grad_restr1 -!----------------------------------------------------------------------------- - subroutine egb1(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne potential of interaction. -! - use calc_data - use energy, only: sc_grad -! use control, only:stopx -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' -! include 'COMMON.CONTROL' - logical :: lprn - real(kind=8) :: evdw -!el local variables - integer :: iint,ind,itypi,itypi1,itypj - real(kind=8) :: xi,yi,zi,rrij,sig,sig0ij,rij_shift,fac,e1,e2,& - sigm,epsi -!elwrite(iout,*) "check evdw" -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - - itypi=iabs(itype(i)) - itypi1=iabs(itype(i+1)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -!elwrite(iout,*) itypi,itypi1,xi,yi,zi,dxi,dyi,dzi,dsci_inv -! -! Calculate SC interaction energy. -! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN - ind=ind+1 - itypj=iabs(itype(j)) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -! For diagnostics only!!! -! chi1=0.0D0 -! chi2=0.0D0 -! chi12=0.0D0 -! chip1=0.0D0 -! chip2=0.0D0 -! chip12=0.0D0 -! alf1=0.0D0 -! alf2=0.0D0 -! alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) -! Calculate angle-dependent terms of energy and contributions to their -! derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -! I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') & -!d restyp(itypi),i,restyp(itypj),j, & -!d rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -!--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -!d write (iout,'(2(a3,i3,2x),17(0pf7.3))') & -!d restyp(itypi),i,restyp(itypj),j, & -!d epsi,sigm,chi1,chi2,chip1,chip2, & -!d eps1,eps2rt**2,eps3rt**2,sig,sig0ij, & -!d om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, & -!d evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'evdw',i,j,evdwij - -! Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -! Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -! Calculate angular part of the gradient. - -!elwrite(iout,*) evdw - call sc_grad -!elwrite(iout,*) "evdw=",evdw,j,iint,i - ENDIF -!elwrite(iout,*) evdw - enddo ! j -!elwrite(iout,*) evdw - enddo ! iint -!elwrite(iout,*) evdw - enddo ! i -!elwrite(iout,*) evdw,i - end subroutine egb1 -!----------------------------------------------------------------------------- -! sumsld.f -!----------------------------------------------------------------------------- - subroutine sumsl(n,d,x,calcf,calcg,iv,liv,lv,v,uiparm,urparm,ufparm) -! -! *** minimize general unconstrained objective function using *** -! *** analytic gradient and hessian approx. from secant update *** -! -! use control - integer :: n, liv, lv - integer :: iv(liv), uiparm(1) - real(kind=8) :: d(n), x(n), v(lv), urparm(1) - real(kind=8),external :: ufparm !funtion name as an argument - -! dimension v(71 + n*(n+15)/2), uiparm(*), urparm(*) - external :: calcf, calcg !subroutine name as an argument -! -! *** purpose *** -! -! this routine interacts with subroutine sumit in an attempt -! to find an n-vector x* that minimizes the (unconstrained) -! objective function computed by calcf. (often the x* found is -! a local minimizer rather than a global one.) -! -!-------------------------- parameter usage -------------------------- -! -! n........ (input) the number of variables on which f depends, i.e., -! the number of components in x. -! d........ (input/output) a scale vector such that d(i)*x(i), -! i = 1,2,...,n, are all in comparable units. -! d can strongly affect the behavior of sumsl. -! finding the best choice of d is generally a trial- -! and-error process. choosing d so that d(i)*x(i) -! has about the same value for all i often works well. -! the defaults provided by subroutine deflt (see i -! below) require the caller to supply d. -! x........ (input/output) before (initially) calling sumsl, the call- -! er should set x to an initial guess at x*. when -! sumsl returns, x contains the best point so far -! found, i.e., the one that gives the least value so -! far seen for f(x). -! calcf.... (input) a subroutine that, given x, computes f(x). calcf -! must be declared external in the calling program. -! it is invoked by -! call calcf(n, x, nf, f, uiparm, urparm, ufparm) -! when calcf is called, nf is the invocation -! count for calcf. nf is included for possible use -! with calcg. if x is out of bounds (e.g., if it -! would cause overflow in computing f(x)), then calcf -! should set nf to 0. this will cause a shorter step -! to be attempted. (if x is in bounds, then calcf -! should not change nf.) the other parameters are as -! described above and below. calcf should not change -! n, p, or x. -! calcg.... (input) a subroutine that, given x, computes g(x), the gra- -! dient of f at x. calcg must be declared external in -! the calling program. it is invoked by -! call calcg(n, x, nf, g, uiparm, urparm, ufaprm) -! when calcg is called, nf is the invocation -! count for calcf at the time f(x) was evaluated. the -! x passed to calcg is usually the one passed to calcf -! on either its most recent invocation or the one -! prior to it. if calcf saves intermediate results -! for use by calcg, then it is possible to tell from -! nf whether they are valid for the current x (or -! which copy is valid if two copies are kept). if g -! cannot be computed at x, then calcg should set nf to -! 0. in this case, sumsl will return with iv(1) = 65. -! (if g can be computed at x, then calcg should not -! changed nf.) the other parameters to calcg are as -! described above and below. calcg should not change -! n or x. -! iv....... (input/output) an integer value array of length liv (see -! below) that helps control the sumsl algorithm and -! that is used to store various intermediate quanti- -! ties. of particular interest are the initialization/ -! return code iv(1) and the entries in iv that control -! printing and limit the number of iterations and func- -! tion evaluations. see the section on iv input -! values below. -! liv...... (input) length of iv array. must be at least 60. if li -! is too small, then sumsl returns with iv(1) = 15. -! when sumsl returns, the smallest allowed value of -! liv is stored in iv(lastiv) -- see the section on -! iv output values below. (this is intended for use -! with extensions of sumsl that handle constraints.) -! lv....... (input) length of v array. must be at least 71+n*(n+15)/2. -! (at least 77+n*(n+17)/2 for smsno, at least -! 78+n*(n+12) for humsl). if lv is too small, then -! sumsl returns with iv(1) = 16. when sumsl returns, -! the smallest allowed value of lv is stored in -! iv(lastv) -- see the section on iv output values -! below. -! v........ (input/output) a floating-point value array of length l -! (see below) that helps control the sumsl algorithm -! and that is used to store various intermediate -! quantities. of particular interest are the entries -! in v that limit the length of the first step -! attempted (lmax0) and specify convergence tolerances -! (afctol, lmaxs, rfctol, sctol, xctol, xftol). -! uiparm... (input) user integer parameter array passed without change -! to calcf and calcg. -! urparm... (input) user floating-point parameter array passed without -! change to calcf and calcg. -! ufparm... (input) user external subroutine or function passed without -! change to calcf and calcg. -! -! *** iv input values (from subroutine deflt) *** -! -! iv(1)... on input, iv(1) should have a value between 0 and 14...... -! 0 and 12 mean this is a fresh start. 0 means that -! deflt(2, iv, liv, lv, v) -! is to be called to provide all default values to iv and -! v. 12 (the value that deflt assigns to iv(1)) means the -! caller has already called deflt and has possibly changed -! some iv and/or v entries to non-default values. -! 13 means deflt has been called and that sumsl (and -! sumit) should only do their storage allocation. that is, -! they should set the output components of iv that tell -! where various subarrays arrays of v begin, such as iv(g) -! (and, for humsl and humit only, iv(dtol)), and return. -! 14 means that a storage has been allocated (by a call -! with iv(1) = 13) and that the algorithm should be -! started. when called with iv(1) = 13, sumsl returns -! iv(1) = 14 unless liv or lv is too small (or n is not -! positive). default = 12. -! iv(inith).... iv(25) tells whether the hessian approximation h should -! be initialized. 1 (the default) means sumit should -! initialize h to the diagonal matrix whose i-th diagonal -! element is d(i)**2. 0 means the caller has supplied a -! cholesky factor l of the initial hessian approximation -! h = l*(l**t) in v, starting at v(iv(lmat)) = v(iv(42)) -! (and stored compactly by rows). note that iv(lmat) may -! be initialized by calling sumsl with iv(1) = 13 (see -! the iv(1) discussion above). default = 1. -! iv(mxfcal)... iv(17) gives the maximum number of function evaluations -! (calls on calcf) allowed. if this number does not suf- -! fice, then sumsl returns with iv(1) = 9. default = 200. -! iv(mxiter)... iv(18) gives the maximum number of iterations allowed. -! it also indirectly limits the number of gradient evalua- -! tions (calls on calcg) to iv(mxiter) + 1. if iv(mxiter) -! iterations do not suffice, then sumsl returns with -! iv(1) = 10. default = 150. -! iv(outlev)... iv(19) controls the number and length of iteration sum- -! mary lines printed (by itsum). iv(outlev) = 0 means do -! not print any summary lines. otherwise, print a summary -! line after each abs(iv(outlev)) iterations. if iv(outlev) -! is positive, then summary lines of length 78 (plus carri- -! age control) are printed, including the following... the -! iteration and function evaluation counts, f = the current -! function value, relative difference in function values -! achieved by the latest step (i.e., reldf = (f0-v(f))/f01, -! where f01 is the maximum of abs(v(f)) and abs(v(f0)) and -! v(f0) is the function value from the previous itera- -! tion), the relative function reduction predicted for the -! step just taken (i.e., preldf = v(preduc) / f01, where -! v(preduc) is described below), the scaled relative change -! in x (see v(reldx) below), the step parameter for the -! step just taken (stppar = 0 means a full newton step, -! between 0 and 1 means a relaxed newton step, between 1 -! and 2 means a double dogleg step, greater than 2 means -! a scaled down cauchy step -- see subroutine dbldog), the -! 2-norm of the scale vector d times the step just taken -! (see v(dstnrm) below), and npreldf, i.e., -! v(nreduc)/f01, where v(nreduc) is described below -- if -! npreldf is positive, then it is the relative function -! reduction predicted for a newton step (one with -! stppar = 0). if npreldf is negative, then it is the -! negative of the relative function reduction predicted -! for a step computed with step bound v(lmaxs) for use in -! testing for singular convergence. -! if iv(outlev) is negative, then lines of length 50 -! are printed, including only the first 6 items listed -! above (through reldx). -! default = 1. -! iv(parprt)... iv(20) = 1 means print any nondefault v values on a -! fresh start or any changed v values on a restart. -! iv(parprt) = 0 means skip this printing. default = 1. -! iv(prunit)... iv(21) is the output unit number on which all printing -! is done. iv(prunit) = 0 means suppress all printing. -! default = standard output unit (unit 6 on most systems). -! iv(solprt)... iv(22) = 1 means print out the value of x returned (as -! well as the gradient and the scale vector d). -! iv(solprt) = 0 means skip this printing. default = 1. -! iv(statpr)... iv(23) = 1 means print summary statistics upon return- -! ing. these consist of the function value, the scaled -! relative change in x caused by the most recent step (see -! v(reldx) below), the number of function and gradient -! evaluations (calls on calcf and calcg), and the relative -! function reductions predicted for the last step taken and -! for a newton step (or perhaps a step bounded by v(lmaxs) -! -- see the descriptions of preldf and npreldf under -! iv(outlev) above). -! iv(statpr) = 0 means skip this printing. -! iv(statpr) = -1 means skip this printing as well as that -! of the one-line termination reason message. default = 1. -! iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d -! (on a fresh start only). iv(x0prt) = 0 means skip this -! printing. default = 1. -! -! *** (selected) iv output values *** -! -! iv(1)........ on output, iv(1) is a return code.... -! 3 = x-convergence. the scaled relative difference (see -! v(reldx)) between the current parameter vector x and -! a locally optimal parameter vector is very likely at -! most v(xctol). -! 4 = relative function convergence. the relative differ- -! ence between the current function value and its lo- -! cally optimal value is very likely at most v(rfctol). -! 5 = both x- and relative function convergence (i.e., the -! conditions for iv(1) = 3 and iv(1) = 4 both hold). -! 6 = absolute function convergence. the current function -! value is at most v(afctol) in absolute value. -! 7 = singular convergence. the hessian near the current -! iterate appears to be singular or nearly so, and a -! step of length at most v(lmaxs) is unlikely to yield -! a relative function decrease of more than v(sctol). -! 8 = false convergence. the iterates appear to be converg- -! ing to a noncritical point. this may mean that the -! convergence tolerances (v(afctol), v(rfctol), -! v(xctol)) are too small for the accuracy to which -! the function and gradient are being computed, that -! there is an error in computing the gradient, or that -! the function or gradient is discontinuous near x. -! 9 = function evaluation limit reached without other con- -! vergence (see iv(mxfcal)). -! 10 = iteration limit reached without other convergence -! (see iv(mxiter)). -! 11 = stopx returned .true. (external interrupt). see the -! usage notes below. -! 14 = storage has been allocated (after a call with -! iv(1) = 13). -! 17 = restart attempted with n changed. -! 18 = d has a negative component and iv(dtype) .le. 0. -! 19...43 = v(iv(1)) is out of range. -! 63 = f(x) cannot be computed at the initial x. -! 64 = bad parameters passed to assess (which should not -! occur). -! 65 = the gradient could not be computed at x (see calcg -! above). -! 67 = bad first parameter to deflt. -! 80 = iv(1) was out of range. -! 81 = n is not positive. -! iv(g)........ iv(28) is the starting subscript in v of the current -! gradient vector (the one corresponding to x). -! iv(lastiv)... iv(44) is the least acceptable value of liv. (it is -! only set if liv is at least 44.) -! iv(lastv).... iv(45) is the least acceptable value of lv. (it is -! only set if liv is large enough, at least iv(lastiv).) -! iv(nfcall)... iv(6) is the number of calls so far made on calcf (i.e., -! function evaluations). -! iv(ngcall)... iv(30) is the number of gradient evaluations (calls on -! calcg). -! iv(niter).... iv(31) is the number of iterations performed. -! -! *** (selected) v input values (from subroutine deflt) *** -! -! v(bias)..... v(43) is the bias parameter used in subroutine dbldog -- -! see that subroutine for details. default = 0.8. -! v(afctol)... v(31) is the absolute function convergence tolerance. -! if sumsl finds a point where the function value is less -! than v(afctol) in absolute value, and if sumsl does not -! return with iv(1) = 3, 4, or 5, then it returns with -! iv(1) = 6. this test can be turned off by setting -! v(afctol) to zero. default = max(10**-20, machep**2), -! where machep is the unit roundoff. -! v(dinit).... v(38), if nonnegative, is the value to which the scale -! vector d is initialized. default = -1. -! v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the -! very first step that sumsl attempts. this parameter can -! markedly affect the performance of sumsl. -! v(lmaxs).... v(36) is used in testing for singular convergence -- if -! the function reduction predicted for a step of length -! bounded by v(lmaxs) is at most v(sctol) * abs(f0), where -! f0 is the function value at the start of the current -! iteration, and if sumsl does not return with iv(1) = 3, -! 4, 5, or 6, then it returns with iv(1) = 7. default = 1. -! v(rfctol)... v(32) is the relative function convergence tolerance. -! if the current model predicts a maximum possible function -! reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) -! at the start of the current iteration, where f0 is the -! then current function value, and if the last step attempt- -! ed achieved no more than twice the predicted function -! decrease, then sumsl returns with iv(1) = 4 (or 5). -! default = max(10**-10, machep**(2/3)), where machep is -! the unit roundoff. -! v(sctol).... v(37) is the singular convergence tolerance -- see the -! description of v(lmaxs) above. -! v(tuner1)... v(26) helps decide when to check for false convergence. -! this is done if the actual function decrease from the -! current step is no more than v(tuner1) times its predict- -! ed value. default = 0.1. -! v(xctol).... v(33) is the x-convergence tolerance. if a newton step -! (see v(nreduc)) is tried that has v(reldx) .le. v(xctol) -! and if this step yields at most twice the predicted func- -! tion decrease, then sumsl returns with iv(1) = 3 (or 5). -! (see the description of v(reldx) below.) -! default = machep**0.5, where machep is the unit roundoff. -! v(xftol).... v(34) is the false convergence tolerance. if a step is -! tried that gives no more than v(tuner1) times the predict- -! ed function decrease and that has v(reldx) .le. v(xftol), -! and if sumsl does not return with iv(1) = 3, 4, 5, 6, or -! 7, then it returns with iv(1) = 8. (see the description -! of v(reldx) below.) default = 100*machep, where -! machep is the unit roundoff. -! v(*)........ deflt supplies to v a number of tuning constants, with -! which it should ordinarily be unnecessary to tinker. see -! section 17 of version 2.2 of the nl2sol usage summary -! (i.e., the appendix to ref. 1) for details on v(i), -! i = decfac, incfac, phmnfc, phmxfc, rdfcmn, rdfcmx, -! tuner2, tuner3, tuner4, tuner5. -! -! *** (selected) v output values *** -! -! v(dgnorm)... v(1) is the 2-norm of (diag(d)**-1)*g, where g is the -! most recently computed gradient. -! v(dstnrm)... v(2) is the 2-norm of diag(d)*step, where step is the -! current step. -! v(f)........ v(10) is the current function value. -! v(f0)....... v(13) is the function value at the start of the current -! iteration. -! v(nreduc)... v(6), if positive, is the maximum function reduction -! possible according to the current model, i.e., the func- -! tion reduction predicted for a newton step (i.e., -! step = -h**-1 * g, where g is the current gradient and -! h is the current hessian approximation). -! if v(nreduc) is negative, then it is the negative of -! the function reduction predicted for a step computed with -! a step bound of v(lmaxs) for use in testing for singular -! convergence. -! v(preduc)... v(7) is the function reduction predicted (by the current -! quadratic model) for the current step. this (divided by -! v(f0)) is used in testing for relative function -! convergence. -! v(reldx).... v(17) is the scaled relative change in x caused by the -! current step, computed as -! max(abs(d(i)*(x(i)-x0(i)), 1 .le. i .le. p) / -! max(d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p), -! where x = x0 + step. -! -!------------------------------- notes ------------------------------- -! -! *** algorithm notes *** -! -! this routine uses a hessian approximation computed from the -! bfgs update (see ref 3). only a cholesky factor of the hessian -! approximation is stored, and this is updated using ideas from -! ref. 4. steps are computed by the double dogleg scheme described -! in ref. 2. the steps are assessed as in ref. 1. -! -! *** usage notes *** -! -! after a return with iv(1) .le. 11, it is possible to restart, -! i.e., to change some of the iv and v input values described above -! and continue the algorithm from the point where it was interrupt- -! ed. iv(1) should not be changed, nor should any entries of i -! and v other than the input values (those supplied by deflt). -! those who do not wish to write a calcg which computes the -! gradient analytically should call smsno rather than sumsl. -! smsno uses finite differences to compute an approximate gradient. -! those who would prefer to provide f and g (the function and -! gradient) by reverse communication rather than by writing subrou- -! tines calcf and calcg may call on sumit directly. see the com- -! ments at the beginning of sumit. -! those who use sumsl interactively may wish to supply their -! own stopx function, which should return .true. if the break key -! has been pressed since stopx was last invoked. this makes it -! possible to externally interrupt sumsl (which will return with -! iv(1) = 11 if stopx returns .true.). -! storage for g is allocated at the end of v. thus the caller -! may make v longer than specified above and may allow calcg to use -! elements of g beyond the first n as scratch storage. -! -! *** portability notes *** -! -! the sumsl distribution tape contains both single- and double- -! precision versions of the sumsl source code, so it should be un- -! necessary to change precisions. -! only the functions imdcon and rmdcon contain machine-dependent -! constants. to change from one machine to another, it should -! suffice to change the (few) relevant lines in these functions. -! intrinsic functions are explicitly declared. on certain com- -! puters (e.g. univac), it may be necessary to comment out these -! declarations. so that this may be done automatically by a simple -! program, such declarations are preceded by a comment having c/+ -! in columns 1-3 and blanks in columns 4-72 and are followed by -! a comment having c/ in columns 1 and 2 and blanks in columns 3-72. -! the sumsl source code is expressed in 1966 ansi standard -! fortran. it may be converted to fortran 77 by commenting out all -! lines that fall between a line having c/6 in columns 1-3 and a -! line having c/7 in columns 1-3 and by removing (i.e., replacing -! by a blank) the c in column 1 of the lines that follow the c/7 -! line and precede a line having c/ in columns 1-2 and blanks in -! columns 3-72. these changes convert some data statements into -! parameter statements, convert some variables from real to -! character*4, and make the data statements that initialize these -! variables use character strings delimited by primes instead -! of hollerith constants. (such variables and data statements -! appear only in modules itsum and parck. parameter statements -! appear nearly everywhere.) these changes also add save state- -! ments for variables given machine-dependent constants by rmdcon. -! -! *** references *** -! -! 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), algorithm 573 -- -! an adaptive nonlinear least-squares algorithm, acm trans. -! math. software 7, pp. 369-383. -! -! 2. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -! mization algorithms which use function and gradient -! values, j. optim. theory applic. 28, pp. 453-482. -! -! 3. dennis, j.e., and more, j.j. (1977), quasi-newton methods, motiva- -! tion and theory, siam rev. 19, pp. 46-89. -! -! 4. goldfarb, d. (1976), factorized variable metric methods for uncon- -! strained optimization, math. comput. 30, pp. 796-811. -! -! *** general *** -! -! coded by david m. gay (winter 1980). revised summer 1982. -! this subroutine was written in connection with research -! supported in part by the national science foundation under -! grants mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, -! and mcs-7906671. -!. -! -!---------------------------- declarations --------------------------- -! -!el external deflt, sumit -! -! deflt... supplies default iv and v input components. -! sumit... reverse-communication routine that carries out sumsl algo- -! rithm. -! - integer :: g1, iv1, nf - real(kind=8) :: f -! -! *** subscripts for iv *** -! -!el integer nextv, nfcall, nfgcal, g, toobig, vneed -! -!/6 -! data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, toobig/2/, vneed/4/ -!/7 - integer,parameter :: nextv=47, nfcall=6, nfgcal=7, g=28,& - toobig=2, vneed=4 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! -!elwrite(iout,*) "in sumsl" - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .eq. 12 .or. iv1 .eq. 13) iv(vneed) = iv(vneed) + n - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -! - 10 g1 = iv(g) -!elwrite(iout,*) "in sumsl go to 10" - -! -!elwrite(iout,*) "in sumsl" - 20 call sumit(d, f, v(g1), iv, liv, lv, n, v, x) -!elwrite(iout,*) "in sumsl, go to 20" - -!elwrite(iout,*) "in sumsl, go to 20, po sumit" -!elwrite(iout,*) "in sumsl iv()", iv(1)-2 - if (iv(1) - 2) 30, 40, 50 -! - 30 nf = iv(nfcall) -!elwrite(iout,*) "in sumsl iv",iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) -!elwrite(iout,*) "in sumsl" - if (nf .le. 0) iv(toobig) = 1 - go to 20 -! -!elwrite(iout,*) "in sumsl" - 40 call calcg(n, x, iv(nfgcal), v(g1), uiparm, urparm, ufparm) -!elwrite(iout,*) "in sumsl" - go to 20 -! - 50 if (iv(1) .ne. 14) go to 999 -! -! *** storage allocation -! - iv(g) = iv(nextv) - iv(nextv) = iv(g) + n - if (iv1 .ne. 13) go to 10 -!elwrite(iout,*) "in sumsl" -! - 999 return -! *** last card of sumsl follows *** - end subroutine sumsl -!----------------------------------------------------------------------------- - subroutine sumit(d,fx,g,iv,liv,lv,n,v,x) - - use control, only:stopx -! -! *** carry out sumsl (unconstrained minimization) iterations, using -! *** double-dogleg/bfgs steps. -! -! *** parameter declarations *** -! - integer :: liv, lv, n - integer :: iv(liv) - real(kind=8) :: d(n), fx, g(n), v(lv), x(n) -! -!-------------------------- parameter usage -------------------------- -! -! d.... scale vector. -! fx... function value. -! g.... gradient vector. -! iv... integer value array. -! liv.. length of iv (at least 60). -! lv... length of v (at least 71 + n*(n+13)/2). -! n.... number of variables (components in x and g). -! v.... floating-point value array. -! x.... vector of parameters to be optimized. -! -! *** discussion *** -! -! parameters iv, n, v, and x are the same as the corresponding -! ones to sumsl (which see), except that v can be shorter (since -! the part of v that sumsl uses for storing g is not needed). -! moreover, compared with sumsl, iv(1) may have the two additional -! output values 1 and 2, which are explained below, as is the use -! of iv(toobig) and iv(nfgcal). the value iv(g), which is an -! output value from sumsl (and smsno), is not referenced by -! sumit or the subroutines it calls. -! fx and g need not have been initialized when sumit is called -! with iv(1) = 12, 13, or 14. -! -! iv(1) = 1 means the caller should set fx to f(x), the function value -! at x, and call sumit again, having changed none of the -! other parameters. an exception occurs if f(x) cannot be -! (e.g. if overflow would occur), which may happen because -! of an oversized step. in this case the caller should set -! iv(toobig) = iv(2) to 1, which will cause sumit to ig- -! nore fx and try a smaller step. the parameter nf that -! sumsl passes to calcf (for possible use by calcg) is a -! copy of iv(nfcall) = iv(6). -! iv(1) = 2 means the caller should set g to g(x), the gradient vector -! of f at x, and call sumit again, having changed none of -! the other parameters except possibly the scale vector d -! when iv(dtype) = 0. the parameter nf that sumsl passes -! to calcg is iv(nfgcal) = iv(7). if g(x) cannot be -! evaluated, then the caller may set iv(nfgcal) to 0, in -! which case sumit will return with iv(1) = 65. -!. -! *** general *** -! -! coded by david m. gay (december 1979). revised sept. 1982. -! this subroutine was written in connection with research supported -! in part by the national science foundation under grants -! mcs-7600324 and mcs-7906671. -! -! (see sumsl for references.) -! -!+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -! -! *** local variables *** -! - integer :: dg1, dummy, g01, i, k, l, lstgst, nwtst1, step1,& - temp1, w, x01, z - real(kind=8) :: t -!el logical :: lstopx -! -! *** constants *** -! -!el real(kind=8) :: half, negone, one, onep2, zero -! -! *** no intrinsic functions *** -! -! *** external functions and subroutines *** -! -!el external assst, dbdog, deflt, dotprd, itsum, litvmu, livmul, -!el 1 ltvmul, lupdat, lvmul, parck, reldst, stopx, vaxpy, -!el 2 vcopy, vscopy, vvmulp, v2norm, wzbfgs -!el logical stopx -!el real(kind=8) :: dotprd, reldst, v2norm -! -! assst.... assesses candidate step. -! dbdog.... computes double-dogleg (candidate) step. -! deflt.... supplies default iv and v input components. -! dotprd... returns inner product of two vectors. -! itsum.... prints iteration summary and info on initial and final x. -! litvmu... multiplies inverse transpose of lower triangle times vector. -! livmul... multiplies inverse of lower triangle times vector. -! ltvmul... multiplies transpose of lower triangle times vector. -! lupdt.... updates cholesky factor of hessian approximation. -! lvmul.... multiplies lower triangle times vector. -! parck.... checks validity of input iv and v values. -! reldst... computes v(reldx) = relative step size. -! stopx.... returns .true. if the break key has been pressed. -! vaxpy.... computes scalar times one vector plus another. -! vcopy.... copies one vector to another. -! vscopy... sets all elements of a vector to a scalar. -! vvmulp... multiplies vector by vector raised to power (componentwise). -! v2norm... returns the 2-norm of a vector. -! wzbfgs... computes w and z for lupdat corresponding to bfgs update. -! -! *** subscripts for iv and v *** -! -!el integer afctol -!el integer cnvcod, dg, dgnorm, dinit, dstnrm, dst0, f, f0, fdif, -!el 1 gthg, gtstep, g0, incfac, inith, irc, kagqt, lmat, lmax0, -!el 2 lmaxs, mode, model, mxfcal, mxiter, nextv, nfcall, nfgcal, -!el 3 ngcall, niter, nreduc, nwtstp, preduc, radfac, radinc, -!el 4 radius, rad0, reldx, restor, step, stglim, stlstg, toobig, -!el 5 tuner4, tuner5, vneed, xirc, x0 -! -! *** iv subscript values *** -! -!/6 -! data cnvcod/55/, dg/37/, g0/48/, inith/25/, irc/29/, kagqt/33/, -! 1 mode/35/, model/5/, mxfcal/17/, mxiter/18/, nfcall/6/, -! 2 nfgcal/7/, ngcall/30/, niter/31/, nwtstp/34/, radinc/8/, -! 3 restor/9/, step/40/, stglim/11/, stlstg/41/, toobig/2/, -! 4 vneed/4/, xirc/13/, x0/43/ -!/7 - integer,parameter :: cnvcod=55, dg=37, g0=48, inith=25, irc=29, kagqt=33,& - mode=35, model=5, mxfcal=17, mxiter=18, nfcall=6,& - nfgcal=7, ngcall=30, niter=31, nwtstp=34, radinc=8,& - restor=9, step=40, stglim=11, stlstg=41, toobig=2,& - vneed=4, xirc=13, x0=43 -!/ -! -! *** v subscript values *** -! -!/6 -! data afctol/31/ -! data dgnorm/1/, dinit/38/, dstnrm/2/, dst0/3/, f/10/, f0/13/, -! 1 fdif/11/, gthg/44/, gtstep/4/, incfac/23/, lmat/42/, -! 2 lmax0/35/, lmaxs/36/, nextv/47/, nreduc/6/, preduc/7/, -! 3 radfac/16/, radius/8/, rad0/9/, reldx/17/, tuner4/29/, -! 4 tuner5/30/ -!/7 - integer,parameter :: afctol=31 - integer,parameter :: dgnorm=1, dinit=38, dstnrm=2, dst0=3, f=10, f0=13,& - fdif=11, gthg=44, gtstep=4, incfac=23, lmat=42,& - lmax0=35, lmaxs=36, nextv=47, nreduc=6, preduc=7,& - radfac=16, radius=8, rad0=9, reldx=17, tuner4=29,& - tuner5=30 -!/ -! -!/6 -! data half/0.5d+0/, negone/-1.d+0/, one/1.d+0/, onep2/1.2d+0/, -! 1 zero/0.d+0/ -!/7 - real(kind=8),parameter :: half=0.5d+0, negone=-1.d+0, one=1.d+0,& - onep2=1.2d+0,zero=0.d+0 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! -! Following SAVE statement inserted. - save l - i = iv(1) - if (i .eq. 1) go to 50 - if (i .eq. 2) go to 60 -! -! *** check validity of iv and v input values *** -! - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) & - iv(vneed) = iv(vneed) + n*(n+13)/2 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - go to (180, 180, 180, 180, 180, 180, 120, 90, 120, 10, 10, 20), i -! -! *** storage allocation *** -! -10 l = iv(lmat) - iv(x0) = l + n*(n+1)/2 - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(g0) = iv(stlstg) + n - iv(nwtstp) = iv(g0) + n - iv(dg) = iv(nwtstp) + n - iv(nextv) = iv(dg) + n - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -! -! *** initialization *** -! - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - if (iv(inith) .ne. 1) go to 40 -! -! *** set the initial hessian approximation to diag(d)**-2 *** -! - l = iv(lmat) - call vscopy(n*(n+1)/2, v(l), zero) - k = l - 1 - do 30 i = 1, n - k = k + i - t = d(i) - if (t .le. zero) t = one - v(k) = t - 30 continue -! -! *** compute initial function value *** -! - 40 iv(1) = 1 - go to 999 -! - 50 v(f) = fx - if (iv(mode) .ge. 0) go to 180 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 300 -! -! *** make sure gradient could be computed *** -! - 60 if (iv(nfgcal) .ne. 0) go to 70 - iv(1) = 65 - go to 300 -! - 70 dg1 = iv(dg) - call vvmulp(n, v(dg1), g, d, -1) - v(dgnorm) = v2norm(n, v(dg1)) -! -! *** test norm of gradient *** -! - if (v(dgnorm) .gt. v(afctol)) go to 75 - iv(irc) = 10 - iv(cnvcod) = iv(irc) - 4 -! - 75 if (iv(cnvcod) .ne. 0) go to 290 - if (iv(mode) .eq. 0) go to 250 -! -! *** allow first step to have scaled 2-norm at most v(lmax0) *** -! - v(radius) = v(lmax0) -! - iv(mode) = 0 -! -! -!----------------------------- main loop ----------------------------- -! -! -! *** print iteration summary, check iteration limit *** -! - 80 call itsum(d, g, iv, liv, lv, n, v, x) - 90 k = iv(niter) - if (k .lt. iv(mxiter)) go to 100 - iv(1) = 10 - go to 300 -! -! *** update radius *** -! - 100 iv(niter) = k + 1 - if(k.gt.0)v(radius) = v(radfac) * v(dstnrm) -! -! *** initialize for start of next iteration *** -! - g01 = iv(g0) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -! -! *** copy x to x0, g to g0 *** -! - call vcopy(n, v(x01), x) - call vcopy(n, v(g01), g) -! -! *** check stopx and function evaluation limit *** -! -! AL 4/30/95 - dummy=iv(nfcall) -!el lstopx = stopx(dummy) -!elwrite(iout,*) "lstopx",lstopx,dummy - 110 if (.not. stopx(dummy)) go to 130 - iv(1) = 11 -! write (iout,*) "iv(1)=11 !!!!" - go to 140 -! -! *** come here when restarting after func. eval. limit or stopx. -! - 120 if (v(f) .ge. v(f0)) go to 130 - v(radfac) = one - k = iv(niter) - go to 100 -! - 130 if (iv(nfcall) .lt. iv(mxfcal)) go to 150 - iv(1) = 9 - 140 if (v(f) .ge. v(f0)) go to 300 -! -! *** in case of stopx or function evaluation limit with -! *** improved v(f), evaluate the gradient at x. -! - iv(cnvcod) = iv(1) - go to 240 -! -!. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -! - 150 step1 = iv(step) - dg1 = iv(dg) - nwtst1 = iv(nwtstp) - if (iv(kagqt) .ge. 0) go to 160 - l = iv(lmat) - call livmul(n, v(nwtst1), v(l), g) - v(nreduc) = half * dotprd(n, v(nwtst1), v(nwtst1)) - call litvmu(n, v(nwtst1), v(l), v(nwtst1)) - call vvmulp(n, v(step1), v(nwtst1), d, 1) - v(dst0) = v2norm(n, v(step1)) - call vvmulp(n, v(dg1), v(dg1), d, -1) - call ltvmul(n, v(step1), v(l), v(dg1)) - v(gthg) = v2norm(n, v(step1)) - iv(kagqt) = 0 - 160 call dbdog(v(dg1), lv, n, v(nwtst1), v(step1), v) - if (iv(irc) .eq. 6) go to 180 -! -! *** check whether evaluating f(x0 + step) looks worthwhile *** -! - if (v(dstnrm) .le. zero) go to 180 - if (iv(irc) .ne. 5) go to 170 - if (v(radfac) .le. one) go to 170 - if (v(preduc) .le. onep2 * v(fdif)) go to 180 -! -! *** compute f(x0 + step) *** -! - 170 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -! -!. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -! - 180 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 190 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -! - 190 k = iv(irc) - go to (200,230,230,230,200,210,220,220,220,220,220,220,280,250), k -! -! *** recompute step with changed radius *** -! - 200 v(radius) = v(radfac) * v(dstnrm) - go to 110 -! -! *** compute step of length v(lmaxs) for singular convergence test. -! - 210 v(radius) = v(lmaxs) - go to 150 -! -! *** convergence or false convergence *** -! - 220 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 290 - if (iv(xirc) .eq. 14) go to 290 - iv(xirc) = 14 -! -!. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -! - 230 if (iv(irc) .ne. 3) go to 240 - step1 = iv(step) - temp1 = iv(stlstg) -! -! *** set temp1 = hessian * step for use in gradient tests *** -! - l = iv(lmat) - call ltvmul(n, v(temp1), v(l), v(step1)) - call lvmul(n, v(temp1), v(l), v(temp1)) -! -! *** compute gradient *** -! - 240 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -! -! *** initializations -- g0 = g - g0, etc. *** -! - 250 g01 = iv(g0) - call vaxpy(n, v(g01), negone, v(g01), g) - step1 = iv(step) - temp1 = iv(stlstg) - if (iv(irc) .ne. 3) go to 270 -! -! *** set v(radfac) by gradient tests *** -! -! *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -! - call vaxpy(n, v(temp1), negone, v(g01), v(temp1)) - call vvmulp(n, v(temp1), v(temp1), d, -1) -! -! *** do gradient tests *** -! - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) & - go to 260 - if (dotprd(n, g, v(step1)) & - .ge. v(gtstep) * v(tuner5)) go to 270 - 260 v(radfac) = v(incfac) -! -! *** update h, loop *** -! - 270 w = iv(nwtstp) - z = iv(x0) - l = iv(lmat) - call wzbfgs(v(l), n, v(step1), v(w), v(g01), v(z)) -! -! ** use the n-vectors starting at v(step1) and v(g01) for scratch.. - call lupdat(v(temp1), v(step1), v(l), v(g01), v(l), n, v(w), v(z)) - iv(1) = 2 - go to 80 -! -!. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -! -! *** bad parameters to assess *** -! - 280 iv(1) = 64 - go to 300 -! -! *** print summary of final iteration and other requested items *** -! - 290 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 300 call itsum(d, g, iv, liv, lv, n, v, x) -! - 999 return -! -! *** last line of sumit follows *** - end subroutine sumit -!----------------------------------------------------------------------------- - subroutine dbdog(dig,lv,n,nwtstp,step,v) -! -! *** compute double dogleg step *** -! -! *** parameter declarations *** -! - integer :: lv, n - real(kind=8) :: dig(n), nwtstp(n), step(n), v(lv) -! -! *** purpose *** -! -! this subroutine computes a candidate step (for use in an uncon- -! strained minimization code) by the double dogleg algorithm of -! dennis and mei (ref. 1), which is a variation on powell*s dogleg -! scheme (ref. 2, p. 95). -! -!-------------------------- parameter usage -------------------------- -! -! dig (input) diag(d)**-2 * g -- see algorithm notes. -! g (input) the current gradient vector. -! lv (input) length of v. -! n (input) number of components in dig, g, nwtstp, and step. -! nwtstp (input) negative newton step -- see algorithm notes. -! step (output) the computed step. -! v (i/o) values array, the following components of which are -! used here... -! v(bias) (input) bias for relaxed newton step, which is v(bias) of -! the way from the full newton to the fully relaxed newton -! step. recommended value = 0.8 . -! v(dgnorm) (input) 2-norm of diag(d)**-1 * g -- see algorithm notes. -! v(dstnrm) (output) 2-norm of diag(d) * step, which is v(radius) -! unless v(stppar) = 0 -- see algorithm notes. -! v(dst0) (input) 2-norm of diag(d) * nwtstp -- see algorithm notes. -! v(grdfac) (output) the coefficient of dig in the step returned -- -! step(i) = v(grdfac)*dig(i) + v(nwtfac)*nwtstp(i). -! v(gthg) (input) square-root of (dig**t) * (hessian) * dig -- see -! algorithm notes. -! v(gtstep) (output) inner product between g and step. -! v(nreduc) (output) function reduction predicted for the full newton -! step. -! v(nwtfac) (output) the coefficient of nwtstp in the step returned -- -! see v(grdfac) above. -! v(preduc) (output) function reduction predicted for the step returned. -! v(radius) (input) the trust region radius. d times the step returned -! has 2-norm v(radius) unless v(stppar) = 0. -! v(stppar) (output) code telling how step was computed... 0 means a -! full newton step. between 0 and 1 means v(stppar) of the -! way from the newton to the relaxed newton step. between -! 1 and 2 means a true double dogleg step, v(stppar) - 1 of -! the way from the relaxed newton to the cauchy step. -! greater than 2 means 1 / (v(stppar) - 1) times the cauchy -! step. -! -!------------------------------- notes ------------------------------- -! -! *** algorithm notes *** -! -! let g and h be the current gradient and hessian approxima- -! tion respectively and let d be the current scale vector. this -! routine assumes dig = diag(d)**-2 * g and nwtstp = h**-1 * g. -! the step computed is the same one would get by replacing g and h -! by diag(d)**-1 * g and diag(d)**-1 * h * diag(d)**-1, -! computing step, and translating step back to the original -! variables, i.e., premultiplying it by diag(d)**-1. -! -! *** references *** -! -! 1. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -! mization algorithms which use function and gradient -! values, j. optim. theory applic. 28, pp. 453-482. -! 2. powell, m.j.d. (1970), a hybrid method for non-linear equations, -! in numerical methods for non-linear equations, edited by -! p. rabinowitz, gordon and breach, london. -! -! *** general *** -! -! coded by david m. gay. -! this subroutine was written in connection with research supported -! by the national science foundation under grants mcs-7600324 and -! mcs-7906671. -! -!------------------------ external quantities ------------------------ -! -! *** functions and subroutines called *** -! -!el external dotprd, v2norm -!el real(kind=8) :: dotprd, v2norm -! -! dotprd... returns inner product of two vectors. -! v2norm... returns 2-norm of a vector. -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dsqrt -!/ -!-------------------------- local variables -------------------------- -! - integer :: i - real(kind=8) :: cfact, cnorm, ctrnwt, ghinvg, femnsq, gnorm,& - nwtnrm, relax, rlambd, t, t1, t2 -!el real(kind=8) :: half, one, two, zero -! -! *** v subscripts *** -! -!el integer bias, dgnorm, dstnrm, dst0, grdfac, gthg, gtstep, -!el 1 nreduc, nwtfac, preduc, radius, stppar -! -! *** data initializations *** -! -!/6 -! data half/0.5d+0/, one/1.d+0/, two/2.d+0/, zero/0.d+0/ -!/7 - real(kind=8),parameter :: half=0.5d+0, one=1.d+0, two=2.d+0, zero=0.d+0 -!/ -! -!/6 -! data bias/43/, dgnorm/1/, dstnrm/2/, dst0/3/, grdfac/45/, -! 1 gthg/44/, gtstep/4/, nreduc/6/, nwtfac/46/, preduc/7/, -! 2 radius/8/, stppar/5/ -!/7 - integer,parameter :: bias=43, dgnorm=1, dstnrm=2, dst0=3, grdfac=45,& - gthg=44, gtstep=4, nreduc=6, nwtfac=46, preduc=7,& - radius=8, stppar=5 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! - nwtnrm = v(dst0) - rlambd = one - if (nwtnrm .gt. zero) rlambd = v(radius) / nwtnrm - gnorm = v(dgnorm) - ghinvg = two * v(nreduc) - v(grdfac) = zero - v(nwtfac) = zero - if (rlambd .lt. one) go to 30 -! -! *** the newton step is inside the trust region *** -! - v(stppar) = zero - v(dstnrm) = nwtnrm - v(gtstep) = -ghinvg - v(preduc) = v(nreduc) - v(nwtfac) = -one - do 20 i = 1, n - 20 step(i) = -nwtstp(i) - go to 999 -! - 30 v(dstnrm) = v(radius) - cfact = (gnorm / v(gthg))**2 -! *** cauchy step = -cfact * g. - cnorm = gnorm * cfact - relax = one - v(bias) * (one - gnorm*cnorm/ghinvg) - if (rlambd .lt. relax) go to 50 -! -! *** step is between relaxed newton and full newton steps *** -! - v(stppar) = one - (rlambd - relax) / (one - relax) - t = -rlambd - v(gtstep) = t * ghinvg - v(preduc) = rlambd * (one - half*rlambd) * ghinvg - v(nwtfac) = t - do 40 i = 1, n - 40 step(i) = t * nwtstp(i) - go to 999 -! - 50 if (cnorm .lt. v(radius)) go to 70 -! -! *** the cauchy step lies outside the trust region -- -! *** step = scaled cauchy step *** -! - t = -v(radius) / gnorm - v(grdfac) = t - v(stppar) = one + cnorm / v(radius) - v(gtstep) = -v(radius) * gnorm - v(preduc) = v(radius)*(gnorm - half*v(radius)*(v(gthg)/gnorm)**2) - do 60 i = 1, n - 60 step(i) = t * dig(i) - go to 999 -! -! *** compute dogleg step between cauchy and relaxed newton *** -! *** femur = relaxed newton step minus cauchy step *** -! - 70 ctrnwt = cfact * relax * ghinvg / gnorm -! *** ctrnwt = inner prod. of cauchy and relaxed newton steps, -! *** scaled by gnorm**-1. - t1 = ctrnwt - gnorm*cfact**2 -! *** t1 = inner prod. of femur and cauchy step, scaled by -! *** gnorm**-1. - t2 = v(radius)*(v(radius)/gnorm) - gnorm*cfact**2 - t = relax * nwtnrm - femnsq = (t/gnorm)*t - ctrnwt - t1 -! *** femnsq = square of 2-norm of femur, scaled by gnorm**-1. - t = t2 / (t1 + dsqrt(t1**2 + femnsq*t2)) -! *** dogleg step = cauchy step + t * femur. - t1 = (t - one) * cfact - v(grdfac) = t1 - t2 = -t * relax - v(nwtfac) = t2 - v(stppar) = two - t - v(gtstep) = t1*gnorm**2 + t2*ghinvg - v(preduc) = -t1*gnorm * ((t2 + one)*gnorm) & - - t2 * (one + half*t2)*ghinvg & - - half * (v(gthg)*t1)**2 - do 80 i = 1, n - 80 step(i) = t1*dig(i) + t2*nwtstp(i) -! - 999 return -! *** last line of dbdog follows *** - end subroutine dbdog -!----------------------------------------------------------------------------- - subroutine ltvmul(n,x,l,y) -! -! *** compute x = (l**t)*y, where l is an n x n lower -! *** triangular matrix stored compactly by rows. x and y may -! *** occupy the same storage. *** -! - integer :: n -!al real(kind=8) :: x(n), l(1), y(n) - real(kind=8) :: x(n), l(n*(n+1)/2), y(n) -! dimension l(n*(n+1)/2) - integer :: i, ij, i0, j - real(kind=8) :: yi !el, zero -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -! - i0 = 0 - do 20 i = 1, n - yi = y(i) - x(i) = zero - do 10 j = 1, i - ij = i0 + j - x(j) = x(j) + yi*l(ij) - 10 continue - i0 = i0 + i - 20 continue - 999 return -! *** last card of ltvmul follows *** - end subroutine ltvmul -!----------------------------------------------------------------------------- - subroutine lupdat(beta,gamma,l,lambda,lplus,n,w,z) -! -! *** compute lplus = secant update of l *** -! -! *** parameter declarations *** -! - integer :: n -!al double precision beta(n), gamma(n), l(1), lambda(n), lplus(1), - real(kind=8) :: beta(n), gamma(n), l(n*(n+1)/2), lambda(n), & - lplus(n*(n+1)/2),w(n), z(n) -! dimension l(n*(n+1)/2), lplus(n*(n+1)/2) -! -!-------------------------- parameter usage -------------------------- -! -! beta = scratch vector. -! gamma = scratch vector. -! l (input) lower triangular matrix, stored rowwise. -! lambda = scratch vector. -! lplus (output) lower triangular matrix, stored rowwise, which may -! occupy the same storage as l. -! n (input) length of vector parameters and order of matrices. -! w (input, destroyed on output) right singular vector of rank 1 -! correction to l. -! z (input, destroyed on output) left singular vector of rank 1 -! correction to l. -! -!------------------------------- notes ------------------------------- -! -! *** application and usage restrictions *** -! -! this routine updates the cholesky factor l of a symmetric -! positive definite matrix to which a secant update is being -! applied -- it computes a cholesky factor lplus of -! l * (i + z*w**t) * (i + w*z**t) * l**t. it is assumed that w -! and z have been chosen so that the updated matrix is strictly -! positive definite. -! -! *** algorithm notes *** -! -! this code uses recurrence 3 of ref. 1 (with d(j) = 1 for all j) -! to compute lplus of the form l * (i + z*w**t) * q, where q -! is an orthogonal matrix that makes the result lower triangular. -! lplus may have some negative diagonal elements. -! -! *** references *** -! -! 1. goldfarb, d. (1976), factorized variable metric methods for uncon- -! strained optimization, math. comput. 30, pp. 796-811. -! -! *** general *** -! -! coded by david m. gay (fall 1979). -! this subroutine was written in connection with research supported -! by the national science foundation under grants mcs-7600324 and -! mcs-7906671. -! -!------------------------ external quantities ------------------------ -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dsqrt -!/ -!-------------------------- local variables -------------------------- -! - integer :: i, ij, j, jj, jp1, k, nm1, np1 - real(kind=8) :: a, b, bj, eta, gj, lj, lij, ljj, nu, s, theta,& - wj, zj -!el real(kind=8) :: one, zero -! -! *** data initializations *** -! -!/6 -! data one/1.d+0/, zero/0.d+0/ -!/7 - real(kind=8),parameter :: one=1.d+0, zero=0.d+0 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! - nu = one - eta = zero - if (n .le. 1) go to 30 - nm1 = n - 1 -! -! *** temporarily store s(j) = sum over k = j+1 to n of w(k)**2 in -! *** lambda(j). -! - s = zero - do 10 i = 1, nm1 - j = n - i - s = s + w(j+1)**2 - lambda(j) = s - 10 continue -! -! *** compute lambda, gamma, and beta by goldfarb*s recurrence 3. -! - do 20 j = 1, nm1 - wj = w(j) - a = nu*z(j) - eta*wj - theta = one + a*wj - s = a*lambda(j) - lj = dsqrt(theta**2 + a*s) - if (theta .gt. zero) lj = -lj - lambda(j) = lj - b = theta*wj + s - gamma(j) = b * nu / lj - beta(j) = (a - b*eta) / lj - nu = -nu / lj - eta = -(eta + (a**2)/(theta - lj)) / lj - 20 continue - 30 lambda(n) = one + (nu*z(n) - eta*w(n))*w(n) -! -! *** update l, gradually overwriting w and z with l*w and l*z. -! - np1 = n + 1 - jj = n * (n + 1) / 2 - do 60 k = 1, n - j = np1 - k - lj = lambda(j) - ljj = l(jj) - lplus(jj) = lj * ljj - wj = w(j) - w(j) = ljj * wj - zj = z(j) - z(j) = ljj * zj - if (k .eq. 1) go to 50 - bj = beta(j) - gj = gamma(j) - ij = jj + j - jp1 = j + 1 - do 40 i = jp1, n - lij = l(ij) - lplus(ij) = lj*lij + bj*w(i) + gj*z(i) - w(i) = w(i) + lij*wj - z(i) = z(i) + lij*zj - ij = ij + i - 40 continue - 50 jj = jj - j - 60 continue -! - 999 return -! *** last card of lupdat follows *** - end subroutine lupdat -!----------------------------------------------------------------------------- - subroutine lvmul(n,x,l,y) -! -! *** compute x = l*y, where l is an n x n lower triangular -! *** matrix stored compactly by rows. x and y may occupy the same -! *** storage. *** -! - integer :: n -!al double precision x(n), l(1), y(n) - real(kind=8) :: x(n), l(n*(n+1)/2), y(n) -! dimension l(n*(n+1)/2) - integer :: i, ii, ij, i0, j, np1 - real(kind=8) :: t !el, zero -!/6 -! data zero/0.d+0/ -!/7 - real(kind=8),parameter :: zero=0.d+0 -!/ -! - np1 = n + 1 - i0 = n*(n+1)/2 - do 20 ii = 1, n - i = np1 - ii - i0 = i0 - i - t = zero - do 10 j = 1, i - ij = i0 + j - t = t + l(ij)*y(j) - 10 continue - x(i) = t - 20 continue - 999 return -! *** last card of lvmul follows *** - end subroutine lvmul -!----------------------------------------------------------------------------- - subroutine vvmulp(n,x,y,z,k) -! -! *** set x(i) = y(i) * z(i)**k, 1 .le. i .le. n (for k = 1 or -1) *** -! - integer :: n, k - real(kind=8) :: x(n), y(n), z(n) - integer :: i -! - if (k .ge. 0) go to 20 - do 10 i = 1, n - 10 x(i) = y(i) / z(i) - go to 999 -! - 20 do 30 i = 1, n - 30 x(i) = y(i) * z(i) - 999 return -! *** last card of vvmulp follows *** - end subroutine vvmulp -!----------------------------------------------------------------------------- - subroutine wzbfgs(l,n,s,w,y,z) -! -! *** compute y and z for lupdat corresponding to bfgs update. -! - integer :: n -!al double precision l(1), s(n), w(n), y(n), z(n) - real(kind=8) :: l(n*(n+1)/2), s(n), w(n), y(n), z(n) -! dimension l(n*(n+1)/2) -! -!-------------------------- parameter usage -------------------------- -! -! l (i/o) cholesky factor of hessian, a lower triang. matrix stored -! compactly by rows. -! n (input) order of l and length of s, w, y, z. -! s (input) the step just taken. -! w (output) right singular vector of rank 1 correction to l. -! y (input) change in gradients corresponding to s. -! z (output) left singular vector of rank 1 correction to l. -! -!------------------------------- notes ------------------------------- -! -! *** algorithm notes *** -! -! when s is computed in certain ways, e.g. by gqtstp or -! dbldog, it is possible to save n**2/2 operations since (l**t)*s -! or l*(l**t)*s is then known. -! if the bfgs update to l*(l**t) would reduce its determinant to -! less than eps times its old value, then this routine in effect -! replaces y by theta*y + (1 - theta)*l*(l**t)*s, where theta -! (between 0 and 1) is chosen to make the reduction factor = eps. -! -! *** general *** -! -! coded by david m. gay (fall 1979). -! this subroutine was written in connection with research supported -! by the national science foundation under grants mcs-7600324 and -! mcs-7906671. -! -!------------------------ external quantities ------------------------ -! -! *** functions and subroutines called *** -! -!el external dotprd, livmul, ltvmul -!el real(kind=8) :: dotprd -! dotprd returns inner product of two vectors. -! livmul multiplies l**-1 times a vector. -! ltvmul multiplies l**t times a vector. -! -! *** intrinsic functions *** -!/+ -!el real(kind=8) :: dsqrt -!/ -!-------------------------- local variables -------------------------- -! - integer :: i - real(kind=8) :: cs, cy, epsrt, shs, ys, theta !el, eps, one -! -! *** data initializations *** -! -!/6 -! data eps/0.1d+0/, one/1.d+0/ -!/7 - real(kind=8),parameter :: eps=0.1d+0, one=1.d+0 -!/ -! -!+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -! - call ltvmul(n, w, l, s) - shs = dotprd(n, w, w) - ys = dotprd(n, y, s) - if (ys .ge. eps*shs) go to 10 - theta = (one - eps) * shs / (shs - ys) - epsrt = dsqrt(eps) - cy = theta / (shs * epsrt) - cs = (one + (theta-one)/epsrt) / shs - go to 20 - 10 cy = one / (dsqrt(ys) * dsqrt(shs)) - cs = one / shs - 20 call livmul(n, z, l, y) - do 30 i = 1, n - 30 z(i) = cy * z(i) - cs * w(i) -! - 999 return -! *** last card of wzbfgs follows *** - end subroutine wzbfgs -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module minimm diff --git a/source/unres/muca_md.F90 b/source/unres/muca_md.F90 new file mode 100644 index 0000000..79189a2 --- /dev/null +++ b/source/unres/muca_md.F90 @@ -0,0 +1,389 @@ + module muca_md +!----------------------------------------------------------------------------- + use io_units + use io_base + use MD_data + use geometry_data, only:nres + implicit none +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! muca_md.f +!----------------------------------------------------------------------------- + subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) + + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MUCA' +! include 'COMMON.MD' + integer :: i,iex + real(kind=8),dimension(nprocs) :: remd_t_bath !(maxprocs) + real(kind=8),dimension(nprocs) :: remd_ene !(maxprocs) +! real(kind=8) :: muca_ene + real(kind=8) :: betai,betaiex,delta + + betai=1.0/(Rb*remd_t_bath(i)) + betaiex=1.0/(Rb*remd_t_bath(iex)) + + delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- & + muca_ene(remd_ene(i),i,remd_t_bath)) & + -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- & + muca_ene(remd_ene(i),iex,remd_t_bath)) + + return + end subroutine muca_delta +!----------------------------------------------------------------------------- + real(kind=8) function muca_ene(energy,i,remd_t_bath) + + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MUCA' +! include 'COMMON.MD' + real(kind=8) :: y,yp,energy + real(kind=8),dimension(nprocs) :: remd_t_bath !(maxprocs) + integer :: i + + if (energy.lt.elowi(i)) then + call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) + muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) + elseif (energy.gt.ehighi(i)) then + call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) + muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) + else + call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) + muca_ene=remd_t_bath(i)*Rb*y + endif + return + end function muca_ene +!----------------------------------------------------------------------------- + subroutine muca_update(energy) + + use control_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MUCA' +! include 'COMMON.CONTROL' +! include 'COMMON.MD' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' + real(kind=8) :: energy + real(kind=8) :: yp1,ypn + integer :: k,i,ismooth,ist,ien,j + logical :: lnotend + + k=int((energy-emuca(1))/hbin)+1 + + IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN + if(energy.ge.ehigh) & + write (iout,*) 'MUCA reject',energy,emuca(k) + if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then + write (iout,*) 'MUCA ehigh',energy,emuca(k) + do i=k,nmuca + hist(i)=hist(i)+1 + enddo + endif + if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 + ELSE + if(k.gt.0.and.k.lt.4*nres) hist(k)=hist(k)+1 + ENDIF + if(mod(imtime,mucadyn).eq.0) then + + do i=1,nmuca + IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN + nemuca(i)=nemuca(i)+dlog(hist(i)+1) + ELSE + if (hist(i).gt.0) hist(i)=dlog(hist(i)) + nemuca(i)=nemuca(i)+hist(i) + ENDIF + hist(i)=0 + write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ',& + imtime,emuca(i),nemuca(i) + enddo + + + lnotend=.true. + ismooth=0 + ist=2 + ien=nmuca-1 + IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN +! lnotend=.false. +! do i=1,nmuca-1 +! do j=i+1,nmuca +! if(nemuca(j).lt.nemuca(i)) lnotend=.true. +! enddo +! enddo + do while(lnotend) + ismooth=ismooth+1 + write (iout,*) 'MUCA update smoothing',ist,ien + do i=ist,ien + nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 + enddo + lnotend=.false. + ist=0 + ien=0 + do i=1,nmuca-1 + do j=i+1,nmuca + if(nemuca(j).lt.nemuca(i)) then + lnotend=.true. + if(ist.eq.0) ist=i-1 + if(ien.lt.j+1) ien=j+1 + endif + enddo + enddo + enddo + ENDIF + + write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth + yp1=0 + ypn=0 + call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) + call print_muca + + endif + return + end subroutine muca_update +!----------------------------------------------------------------------------- + real(kind=8) function muca_factor(energy) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MUCA' + real(kind=8) :: y,yp,energy + + if (energy.lt.elow) then + call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) + elseif (energy.gt.ehigh) then + call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) + else + call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) + endif + + if(yp.ge.factor_min) then + muca_factor=yp + else + muca_factor=factor_min + endif +!d print *,'energy, muca_factor',energy,muca_factor + return + end function muca_factor +!----------------------------------------------------------------------------- + subroutine spline(x,y,n,yp1,ypn,y2) + + INTEGER :: n + REAL(kind=8) :: yp1,ypn,x(n),y(n),y2(n) + integer,PARAMETER :: NMAX=500 + INTEGER :: i,k + REAL(kind=8) :: p,qn,sig,un,u(NMAX) + if (yp1.gt..99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do i=2,n-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) & + /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + enddo + if (ypn.gt..99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + endif + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + do k=n-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) + enddo + return + end subroutine spline +!----------------------------------------------------------------------------- + subroutine splint(xa,ya,y2a,n,x,y,yp) + + INTEGER :: n + REAL(kind=8) :: x,y,xa(n),y2a(n),ya(n),yp + INTEGER :: k,khi,klo + REAL(kind=8) :: a,b,h + klo=1 + khi=n + 1 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if (xa(k).gt.x) then + khi=k + else + klo=k + endif + goto 1 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) pause 'bad xa input in splint' + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+ & + ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. + yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. & + +(3*(b**2)-1)*y2a(khi)*h/6. + return + end subroutine splint +!----------------------------------------------------------------------------- +! muca_md.f io_md +!----------------------------------------------------------------------------- + subroutine read_muca + + use control_data, only: modecalc,maxprocs + use MD_data + use REMD_data + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MUCA' +! include 'COMMON.CONTROL' +! include 'COMMON.MD' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' + real(kind=8) :: yp1,ypn,yp,x,y,muca_ene !,muca_factor +!el local variable + real(kind=8) :: emuca_alloc(4*maxres),nemuca_alloc(4*maxres) + integer(kind=2) :: i2rep_alloc(0:maxprocs) + integer :: i,k,j +! real(kind=8) :: var,ene + + imtime=0 + allocate(hist(4*maxres)) !(4*maxres) +!el allocate(i2rep(0:nodes+1)) !(0:maxprocs) + do i=1,4*maxres + hist(i)=0 + enddo + if (modecalc.eq.14.and..not.remd_tlist) then + print *,"MUCAREMD works only with TLIST" + stop + endif + open(89,file='muca.input') + read(89,*) + read(89,*) + if (modecalc.eq.14) then + allocate(elowi(nrep),ehighi(nrep)) !(maxprocs) + read(89,*) (elowi(i),ehighi(i),i=1,nrep) + if (remd_mlist) then + k=0 + do i=1,nrep + do j=1,remd_m(i) + i2rep_alloc(k)=i +!el i2rep(k)=i + k=k+1 + enddo + enddo + allocate(i2rep(k)) !(0:maxprocs) + do j=0,k + i2rep(j)=i2rep_alloc(j) + enddo + elow=elowi(i2rep(me)) + ehigh=ehighi(i2rep(me)) + elowi(me+1)=elow + ehighi(me+1)=ehigh + else + elow=elowi(me+1) + ehigh=ehighi(me+1) + endif + else + read(89,*) elow,ehigh + elowi(1)=elow + ehighi(1)=ehigh + endif + i=0 + do while(.true.) + i=i+1 + read(89,*,end=100) emuca_alloc(i),nemuca_alloc(i) +!d nemuca(i)=nemuca(i)*remd_t(me+1)*Rb + enddo + allocate(emuca(i),nemuca(i),nemuca2(i)) !4*maxres + do j=1,i + emuca(j)=emuca_alloc(j) + nemuca(j)=nemuca_alloc(j) + enddo + 100 continue + nmuca=i-1 + hbin=emuca(nmuca)-emuca(nmuca-1) + write (iout,*) 'hbin',hbin + write (iout,*) me,'elow,ehigh',elow,ehigh + yp1=0 + ypn=0 + call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) + factor_min=0.0d0 + factor_min=muca_factor(ehigh) + call print_muca + return + end subroutine read_muca +!----------------------------------------------------------------------------- + subroutine print_muca + + use control_data, only: modecalc,mucadyn,maxprocs + use MD_data + use REMD_data + use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.MUCA' +! include 'COMMON.CONTROL' +! include 'COMMON.MD' +! include 'COMMON.REMD' +! include 'COMMON.SETUP' +! include 'COMMON.IOUNITS' + real(kind=8) :: yp1,ypn,yp,x,y !,muca_ene,muca_factor + real(kind=8) :: dummy(maxprocs) +!el local variables + integer :: i,j,k + + if (remd_mlist) then + k=0 + do i=1,nrep + do j=1,remd_m(i) + i2rep(k)=i + k=k+1 + enddo + enddo + endif + + do i=1,nmuca +! print *,'nemuca ',emuca(i),nemuca(i) + do j=0,4 + x=emuca(i)+hbin/5*j + if (modecalc.eq.14) then + if (remd_mlist) then + yp=muca_factor(x)*remd_t(i2rep(me))*Rb + dummy(me+1)=remd_t(i2rep(me)) + y=muca_ene(x,me+1,dummy) + else + yp=muca_factor(x)*remd_t(me+1)*Rb + y=muca_ene(x,me+1,remd_t) + endif + write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime,& + 'muca factor ',x,yp,' muca ene',y + else + yp=muca_factor(x)*t_bath*Rb + dummy(1)=t_bath + y=muca_ene(x,1,dummy) + write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime,& + 'muca factor ',x,yp,' muca ene',y + endif + enddo + enddo + if(mucadyn.gt.0) then + do i=1,nmuca + write(iout,'(a13,i8,2f12.5)') 'nemuca after ',& + imtime,emuca(i),nemuca(i) + enddo + endif + return + end subroutine print_muca +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module muca_md diff --git a/source/unres/muca_md.f90 b/source/unres/muca_md.f90 deleted file mode 100644 index 79189a2..0000000 --- a/source/unres/muca_md.f90 +++ /dev/null @@ -1,389 +0,0 @@ - module muca_md -!----------------------------------------------------------------------------- - use io_units - use io_base - use MD_data - use geometry_data, only:nres - implicit none -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! muca_md.f -!----------------------------------------------------------------------------- - subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) - - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MUCA' -! include 'COMMON.MD' - integer :: i,iex - real(kind=8),dimension(nprocs) :: remd_t_bath !(maxprocs) - real(kind=8),dimension(nprocs) :: remd_ene !(maxprocs) -! real(kind=8) :: muca_ene - real(kind=8) :: betai,betaiex,delta - - betai=1.0/(Rb*remd_t_bath(i)) - betaiex=1.0/(Rb*remd_t_bath(iex)) - - delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- & - muca_ene(remd_ene(i),i,remd_t_bath)) & - -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- & - muca_ene(remd_ene(i),iex,remd_t_bath)) - - return - end subroutine muca_delta -!----------------------------------------------------------------------------- - real(kind=8) function muca_ene(energy,i,remd_t_bath) - - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MUCA' -! include 'COMMON.MD' - real(kind=8) :: y,yp,energy - real(kind=8),dimension(nprocs) :: remd_t_bath !(maxprocs) - integer :: i - - if (energy.lt.elowi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) - elseif (energy.gt.ehighi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - muca_ene=remd_t_bath(i)*Rb*y - endif - return - end function muca_ene -!----------------------------------------------------------------------------- - subroutine muca_update(energy) - - use control_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MUCA' -! include 'COMMON.CONTROL' -! include 'COMMON.MD' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' - real(kind=8) :: energy - real(kind=8) :: yp1,ypn - integer :: k,i,ismooth,ist,ien,j - logical :: lnotend - - k=int((energy-emuca(1))/hbin)+1 - - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN - if(energy.ge.ehigh) & - write (iout,*) 'MUCA reject',energy,emuca(k) - if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then - write (iout,*) 'MUCA ehigh',energy,emuca(k) - do i=k,nmuca - hist(i)=hist(i)+1 - enddo - endif - if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 - ELSE - if(k.gt.0.and.k.lt.4*nres) hist(k)=hist(k)+1 - ENDIF - if(mod(imtime,mucadyn).eq.0) then - - do i=1,nmuca - IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN - nemuca(i)=nemuca(i)+dlog(hist(i)+1) - ELSE - if (hist(i).gt.0) hist(i)=dlog(hist(i)) - nemuca(i)=nemuca(i)+hist(i) - ENDIF - hist(i)=0 - write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ',& - imtime,emuca(i),nemuca(i) - enddo - - - lnotend=.true. - ismooth=0 - ist=2 - ien=nmuca-1 - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN -! lnotend=.false. -! do i=1,nmuca-1 -! do j=i+1,nmuca -! if(nemuca(j).lt.nemuca(i)) lnotend=.true. -! enddo -! enddo - do while(lnotend) - ismooth=ismooth+1 - write (iout,*) 'MUCA update smoothing',ist,ien - do i=ist,ien - nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 - enddo - lnotend=.false. - ist=0 - ien=0 - do i=1,nmuca-1 - do j=i+1,nmuca - if(nemuca(j).lt.nemuca(i)) then - lnotend=.true. - if(ist.eq.0) ist=i-1 - if(ien.lt.j+1) ien=j+1 - endif - enddo - enddo - enddo - ENDIF - - write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - call print_muca - - endif - return - end subroutine muca_update -!----------------------------------------------------------------------------- - real(kind=8) function muca_factor(energy) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MUCA' - real(kind=8) :: y,yp,energy - - if (energy.lt.elow) then - call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) - elseif (energy.gt.ehigh) then - call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - endif - - if(yp.ge.factor_min) then - muca_factor=yp - else - muca_factor=factor_min - endif -!d print *,'energy, muca_factor',energy,muca_factor - return - end function muca_factor -!----------------------------------------------------------------------------- - subroutine spline(x,y,n,yp1,ypn,y2) - - INTEGER :: n - REAL(kind=8) :: yp1,ypn,x(n),y(n),y2(n) - integer,PARAMETER :: NMAX=500 - INTEGER :: i,k - REAL(kind=8) :: p,qn,sig,un,u(NMAX) - if (yp1.gt..99e30) then - y2(1)=0. - u(1)=0. - else - y2(1)=-0.5 - u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) - endif - do i=2,n-1 - sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) - p=sig*y2(i-1)+2. - y2(i)=(sig-1.)/p - u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) & - /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p - enddo - if (ypn.gt..99e30) then - qn=0. - un=0. - else - qn=0.5 - un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) - endif - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - enddo - return - end subroutine spline -!----------------------------------------------------------------------------- - subroutine splint(xa,ya,y2a,n,x,y,yp) - - INTEGER :: n - REAL(kind=8) :: x,y,xa(n),y2a(n),ya(n),yp - INTEGER :: k,khi,klo - REAL(kind=8) :: a,b,h - klo=1 - khi=n - 1 if (khi-klo.gt.1) then - k=(khi+klo)/2 - if (xa(k).gt.x) then - khi=k - else - klo=k - endif - goto 1 - endif - h=xa(khi)-xa(klo) - if (h.eq.0.) pause 'bad xa input in splint' - a=(xa(khi)-x)/h - b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+ & - ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. - yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. & - +(3*(b**2)-1)*y2a(khi)*h/6. - return - end subroutine splint -!----------------------------------------------------------------------------- -! muca_md.f io_md -!----------------------------------------------------------------------------- - subroutine read_muca - - use control_data, only: modecalc,maxprocs - use MD_data - use REMD_data - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MUCA' -! include 'COMMON.CONTROL' -! include 'COMMON.MD' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' - real(kind=8) :: yp1,ypn,yp,x,y,muca_ene !,muca_factor -!el local variable - real(kind=8) :: emuca_alloc(4*maxres),nemuca_alloc(4*maxres) - integer(kind=2) :: i2rep_alloc(0:maxprocs) - integer :: i,k,j -! real(kind=8) :: var,ene - - imtime=0 - allocate(hist(4*maxres)) !(4*maxres) -!el allocate(i2rep(0:nodes+1)) !(0:maxprocs) - do i=1,4*maxres - hist(i)=0 - enddo - if (modecalc.eq.14.and..not.remd_tlist) then - print *,"MUCAREMD works only with TLIST" - stop - endif - open(89,file='muca.input') - read(89,*) - read(89,*) - if (modecalc.eq.14) then - allocate(elowi(nrep),ehighi(nrep)) !(maxprocs) - read(89,*) (elowi(i),ehighi(i),i=1,nrep) - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep_alloc(k)=i -!el i2rep(k)=i - k=k+1 - enddo - enddo - allocate(i2rep(k)) !(0:maxprocs) - do j=0,k - i2rep(j)=i2rep_alloc(j) - enddo - elow=elowi(i2rep(me)) - ehigh=ehighi(i2rep(me)) - elowi(me+1)=elow - ehighi(me+1)=ehigh - else - elow=elowi(me+1) - ehigh=ehighi(me+1) - endif - else - read(89,*) elow,ehigh - elowi(1)=elow - ehighi(1)=ehigh - endif - i=0 - do while(.true.) - i=i+1 - read(89,*,end=100) emuca_alloc(i),nemuca_alloc(i) -!d nemuca(i)=nemuca(i)*remd_t(me+1)*Rb - enddo - allocate(emuca(i),nemuca(i),nemuca2(i)) !4*maxres - do j=1,i - emuca(j)=emuca_alloc(j) - nemuca(j)=nemuca_alloc(j) - enddo - 100 continue - nmuca=i-1 - hbin=emuca(nmuca)-emuca(nmuca-1) - write (iout,*) 'hbin',hbin - write (iout,*) me,'elow,ehigh',elow,ehigh - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - factor_min=0.0d0 - factor_min=muca_factor(ehigh) - call print_muca - return - end subroutine read_muca -!----------------------------------------------------------------------------- - subroutine print_muca - - use control_data, only: modecalc,mucadyn,maxprocs - use MD_data - use REMD_data - use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.MUCA' -! include 'COMMON.CONTROL' -! include 'COMMON.MD' -! include 'COMMON.REMD' -! include 'COMMON.SETUP' -! include 'COMMON.IOUNITS' - real(kind=8) :: yp1,ypn,yp,x,y !,muca_ene,muca_factor - real(kind=8) :: dummy(maxprocs) -!el local variables - integer :: i,j,k - - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - endif - - do i=1,nmuca -! print *,'nemuca ',emuca(i),nemuca(i) - do j=0,4 - x=emuca(i)+hbin/5*j - if (modecalc.eq.14) then - if (remd_mlist) then - yp=muca_factor(x)*remd_t(i2rep(me))*Rb - dummy(me+1)=remd_t(i2rep(me)) - y=muca_ene(x,me+1,dummy) - else - yp=muca_factor(x)*remd_t(me+1)*Rb - y=muca_ene(x,me+1,remd_t) - endif - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime,& - 'muca factor ',x,yp,' muca ene',y - else - yp=muca_factor(x)*t_bath*Rb - dummy(1)=t_bath - y=muca_ene(x,1,dummy) - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime,& - 'muca factor ',x,yp,' muca ene',y - endif - enddo - enddo - if(mucadyn.gt.0) then - do i=1,nmuca - write(iout,'(a13,i8,2f12.5)') 'nemuca after ',& - imtime,emuca(i),nemuca(i) - enddo - endif - return - end subroutine print_muca -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module muca_md diff --git a/source/unres/prng.F90 b/source/unres/prng.F90 new file mode 100644 index 0000000..a3ced54 --- /dev/null +++ b/source/unres/prng.F90 @@ -0,0 +1,538 @@ + module prng + implicit none +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! +! block data prngblk + integer,parameter :: nmax=1021 + integer(kind=8),dimension(2,0:nmax) :: iparam +! common/ksrprng/iparam(2,0:nmax) + integer,private :: i + data (iparam(1,i),iparam(2,i),i= 0, 29) / & + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241,& + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271,& + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339,& + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363,& + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379,& + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451,& + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489,& + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523,& + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553,& + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / + data (iparam(1,i),iparam(2,i),i= 30, 59) / & + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663,& + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691,& + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717,& + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741,& + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787,& + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853,& + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873,& + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919,& + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961,& + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / + data (iparam(1,i),iparam(2,i),i= 60, 89) / & + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069,& + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093,& + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129,& + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183,& + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237,& + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251,& + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291,& + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339,& + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399,& + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / + data (iparam(1,i),iparam(2,i),i= 90, 119) / & + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473,& + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507,& + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569,& + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599,& + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653,& + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683,& + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699,& + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713,& + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743,& + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / + data (iparam(1,i),iparam(2,i),i= 120, 149) / & + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809,& + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881,& + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923,& + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987,& + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019,& + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049,& + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077,& + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121,& + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149,& + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / + data (iparam(1,i),iparam(2,i),i= 150, 179) / & + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259,& + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301,& + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367,& + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389,& + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437,& + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511,& + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557,& + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667,& + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701,& + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / + data (iparam(1,i),iparam(2,i),i= 180, 209) / & + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829,& + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877,& + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913,& + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941,& + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961,& + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997,& + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051,& + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093,& + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127,& + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / + data (iparam(1,i),iparam(2,i),i= 210, 239) / & + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219,& + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309,& + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349,& + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373,& + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423,& + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481,& + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523,& + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549,& + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589,& + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / + data (iparam(1,i),iparam(2,i),i= 240, 269) / & + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621,& + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673,& + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753,& + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793,& + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841,& + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891,& + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927,& + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967,& + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051,& + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / + data (iparam(1,i),iparam(2,i),i= 270, 299) / & + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147,& + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171,& + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221,& + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263,& + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287,& + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303,& + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339,& + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369,& + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459,& + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / + data (iparam(1,i),iparam(2,i),i= 300, 329) / & + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557,& + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591,& + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623,& + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657,& + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719,& + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767,& + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807,& + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833,& + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873,& + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / + data (iparam(1,i),iparam(2,i),i= 330, 359) / & + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959,& + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989,& + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019,& + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133,& + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181,& + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221,& + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307,& + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329,& + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419,& + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / + data (iparam(1,i),iparam(2,i),i= 360, 389) / & + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529,& + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601,& + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629,& + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679,& + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731,& + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773,& + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839,& + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869,& + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889,& + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / + data (iparam(1,i),iparam(2,i),i= 390, 419) / & + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979,& + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009,& + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061,& + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163,& + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247,& + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279,& + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331,& + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379,& + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429,& + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / + data (iparam(1,i),iparam(2,i),i= 420, 449) / & + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489,& + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523,& + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571,& + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607,& + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709,& + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783,& + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847,& + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877,& + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897,& + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / + data (iparam(1,i),iparam(2,i),i= 450, 479) / & + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979,& + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023,& + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111,& + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149,& + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203,& + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231,& + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303,& + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329,& + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353,& + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / + data (iparam(1,i),iparam(2,i),i= 480, 509) / & + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399,& + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489,& + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521,& + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551,& + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587,& + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653,& + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689,& + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731,& + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747,& + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / + data (iparam(1,i),iparam(2,i),i= 510, 539) / & + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827,& + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881,& + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933,& + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993,& + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023,& + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101,& + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139,& + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179,& + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223,& + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / + data (iparam(1,i),iparam(2,i),i= 540, 569) / & + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307,& + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343,& + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373,& + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461,& + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479,& + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541,& + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583,& + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653,& + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697,& + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / + data (iparam(1,i),iparam(2,i),i= 570, 599) / & + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811,& + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857,& + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899,& + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953,& + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033,& + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049,& + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073,& + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093,& + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127,& + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / + data (iparam(1,i),iparam(2,i),i= 600, 629) / & + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243,& + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277,& + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309,& + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333,& + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369,& + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409,& + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451,& + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477,& + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499,& + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / + data (iparam(1,i),iparam(2,i),i= 630, 659) / & + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589,& + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621,& + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693,& + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711,& + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759,& + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787,& + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817,& + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837,& + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883,& + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / + data (iparam(1,i),iparam(2,i),i= 660, 689) / & + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991,& + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017,& + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039,& + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059,& + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131,& + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177,& + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227,& + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269,& + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291,& + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / + data (iparam(1,i),iparam(2,i),i= 690, 719) / & + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387,& + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447,& + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543,& + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569,& + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597,& + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657,& + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701,& + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729,& + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783,& + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / + data (iparam(1,i),iparam(2,i),i= 720, 749) / & + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893,& + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947,& + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971,& + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031,& + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073,& + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083,& + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137,& + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157,& + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179,& + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / + data (iparam(1,i),iparam(2,i),i= 750, 779) / & + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269,& + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311,& + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371,& + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427,& + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457,& + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481,& + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503,& + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541,& + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571,& + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / + data (iparam(1,i),iparam(2,i),i= 780, 809) / & + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713,& + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751,& + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821,& + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853,& + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893,& + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917,& + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961,& + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997,& + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039,& + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / + data (iparam(1,i),iparam(2,i),i= 810, 839) / & + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109,& + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151,& + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223,& + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267,& + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327,& + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411,& + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483,& + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493,& + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567,& + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / + data (iparam(1,i),iparam(2,i),i= 840, 869) / & + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643,& + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669,& + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697,& + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727,& + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777,& + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811,& + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867,& + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963,& + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993,& + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / + data (iparam(1,i),iparam(2,i),i= 870, 899) / & + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093,& + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131,& + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167,& + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207,& + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231,& + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293,& + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327,& + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363,& + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407,& + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / + data (iparam(1,i),iparam(2,i),i= 900, 929) / & + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527,& + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557,& + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579,& + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611,& + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639,& + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671,& + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693,& + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713,& + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803,& + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / + data (iparam(1,i),iparam(2,i),i= 930, 959) / & + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887,& + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921,& + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959,& + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013,& + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049,& + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157,& + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203,& + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229,& + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241,& + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / + data (iparam(1,i),iparam(2,i),i= 960, 989) / & + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313,& + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353,& + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439,& + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527,& + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569,& + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611,& + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673,& + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703,& + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791,& + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / + data (iparam(1,i),iparam(2,i),i= 990,1019) / & + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881,& + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959,& + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997,& + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037,& + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067,& + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109,& + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133,& + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171,& + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213,& + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / + data (iparam(1,i),iparam(2,i),i=1020,1021) / & + 11863259, 11863259, 11863279, 11863279 / +! end +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! prng.f +!----------------------------------------------------------------------------- + real(kind=8) function prng_next(me) +! implicit none + integer :: me +! +! Calling sequence: +! = prng_next ( ) +! = vprng ( , , ) +! +! This code is based on a sequential algorithm provided by Mal Kalos. +! This version uses a single 64-bit word to store the initial seeds +! and additive constants. +! A 64-bit floating point number is returned. +! +! The array "iparam" is full-word aligned, being padded by zeros to +! let each generator be on a subpage boundary. +! That is, rows 1 and 2 in a given column of the array are for real, +! rows 3-16 are bogus. +! +! July 12, 1993: double the number of sequences. We should have been +! using two packets per seed, rather than four +! October 31, 1993: merge the two arrays of seeds and constants, +! and switch to 64-bit arithmetic. +! June 1994: port to RS6K. Internal state is kept as 2 64-bit integers +! The ishft function is defined only on 32-bit integers, so we will +! shift numbers by dividing by 2**11 and then adding on 2**53-1. +! +! November 1994: ishift now works on 64-bit numbers (though it gives a +! warning). Thus we go back to using it. John Zollweg also added the +! vprng() routine to return vectors of real*8 random numbers. +! + real(kind=8),parameter :: recip53 = 2.0D0**(-53) + integer(kind=8),parameter :: two = 2**11 + integer(kind=8) :: m,ishift +! parameter ( m = 34522712143931 ) ! 11**13 +! parameter ( ishift = 9007199254740991 ) ! 2**53-1 + +!EL integer,parameter :: nmax = 1021 +!EL integer(kind=8) :: iparam +!EL common/ksrprng/iparam(2,0:nmax) + + integer(kind=8) :: next + +!rc g77 doesn't support integer*8 constants + m = dint(34522712143931.0d0) + ishift = dint(9007199254740991.0d0) + +! RS6K porting note: ishift now takes 64-bit integers , with a warning + if ( 0.le.me .and. me.le.nmax ) then + next = iparam(1,me)*m + iparam(2,me) + iparam(1,me) = next + prng_next = recip53 * ishft( next, -11 ) + else + prng_next=-1.0D0 + endif + + end function prng_next +!----------------------------------------------------------------------------- + subroutine vprng(me,rn,num) + + real(kind=8),parameter :: recip53 = 2.0D0**(-53) + real(kind=8),dimension(1) :: rn + integer(kind=8) :: m +!EL,iparam +! parameter ( m = 34522712143931 ) ! 11**13 +!EL integer,parameter :: nmax=1021 + integer :: num, me,i + +!EL common/ksrprng/iparam(2,0:nmax) + + integer(kind=8) :: next + +!rc g77 doesn't support integer*8 constants + m = dint(34522712143931.0d0) + + if ( 0.le.me .and. me.le.nmax ) then + do 1 i=1,num + next = iparam(1,me)*m + iparam(2,me) + iparam(1,me) = next + rn(i) = recip53 * ishft( next, -11 ) + 1 continue + else + rn(1)=-1.0D0 + endif + return + end subroutine vprng +!----------------------------------------------------------------------------- +! +! prng_chkpnt Get the current state of a generator +! +! Calling sequence: +! logical prng_chkpnt, status +! status = prng_chkpnt (me, iseed) where +! +! me is the particular generator whose state is being gotten +! seed is an 4-element integer array where the "l"-values will be saved +! + logical function prng_chkpnt(me,iseed) +! implicit none + integer :: me + integer(kind=8) :: iseed + +!EL integer,parameter :: nmax=1021 +!EL integer(kind=8) :: iparam +!EL common/ksrprng/iparam(2,0:nmax) + + if (me .lt. 0 .or. me .gt. nmax) then + prng_chkpnt=.false. + else + prng_chkpnt=.true. + iseed=iparam(1,me) + endif + end function prng_chkpnt +!----------------------------------------------------------------------------- +! +! prng_restart Restart generator from a saved state +! +! Calling sequence: +! logical prng_restart, status +! status = prng_restart (me, iseed) where +! +! me is the particular generator being restarted +! iseed is a 8-byte integer containing the "l"-values +! + logical function prng_restart(me,iseed) +! implicit none + integer :: me + integer(kind=8) :: iseed + +!EL integer,parameter :: nmax=1021 +!EL integer(kind=8) :: iparam +!EL common/ksrprng/iparam(2,0:nmax) + + if (me .lt. 0 .or. me .gt. nmax) then + prng_restart=.false. + return + else + prng_restart=.true. + iparam(1,me)=iseed + endif + end function prng_restart +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module prng diff --git a/source/unres/prng.f90 b/source/unres/prng.f90 deleted file mode 100644 index a3ced54..0000000 --- a/source/unres/prng.f90 +++ /dev/null @@ -1,538 +0,0 @@ - module prng - implicit none -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! -! block data prngblk - integer,parameter :: nmax=1021 - integer(kind=8),dimension(2,0:nmax) :: iparam -! common/ksrprng/iparam(2,0:nmax) - integer,private :: i - data (iparam(1,i),iparam(2,i),i= 0, 29) / & - 11848219, 11848219, 11848237, 11848237, 11848241, 11848241,& - 11848247, 11848247, 11848253, 11848253, 11848271, 11848271,& - 11848297, 11848297, 11848313, 11848313, 11848339, 11848339,& - 11848351, 11848351, 11848357, 11848357, 11848363, 11848363,& - 11848367, 11848367, 11848373, 11848373, 11848379, 11848379,& - 11848393, 11848393, 11848433, 11848433, 11848451, 11848451,& - 11848469, 11848469, 11848477, 11848477, 11848489, 11848489,& - 11848493, 11848493, 11848513, 11848513, 11848523, 11848523,& - 11848531, 11848531, 11848537, 11848537, 11848553, 11848553,& - 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / - data (iparam(1,i),iparam(2,i),i= 30, 59) / & - 11848619, 11848619, 11848637, 11848637, 11848663, 11848663,& - 11848673, 11848673, 11848679, 11848679, 11848691, 11848691,& - 11848699, 11848699, 11848709, 11848709, 11848717, 11848717,& - 11848721, 11848721, 11848729, 11848729, 11848741, 11848741,& - 11848751, 11848751, 11848757, 11848757, 11848787, 11848787,& - 11848801, 11848801, 11848829, 11848829, 11848853, 11848853,& - 11848861, 11848861, 11848867, 11848867, 11848873, 11848873,& - 11848891, 11848891, 11848909, 11848909, 11848919, 11848919,& - 11848931, 11848931, 11848937, 11848937, 11848961, 11848961,& - 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / - data (iparam(1,i),iparam(2,i),i= 60, 89) / & - 11849053, 11849053, 11849059, 11849059, 11849069, 11849069,& - 11849077, 11849077, 11849087, 11849087, 11849093, 11849093,& - 11849107, 11849107, 11849111, 11849111, 11849129, 11849129,& - 11849137, 11849137, 11849177, 11849177, 11849183, 11849183,& - 11849203, 11849203, 11849231, 11849231, 11849237, 11849237,& - 11849239, 11849239, 11849249, 11849249, 11849251, 11849251,& - 11849269, 11849269, 11849273, 11849273, 11849291, 11849291,& - 11849297, 11849297, 11849309, 11849309, 11849339, 11849339,& - 11849359, 11849359, 11849363, 11849363, 11849399, 11849399,& - 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / - data (iparam(1,i),iparam(2,i),i= 90, 119) / & - 11849437, 11849437, 11849443, 11849443, 11849473, 11849473,& - 11849491, 11849491, 11849503, 11849503, 11849507, 11849507,& - 11849557, 11849557, 11849567, 11849567, 11849569, 11849569,& - 11849573, 11849573, 11849587, 11849587, 11849599, 11849599,& - 11849633, 11849633, 11849641, 11849641, 11849653, 11849653,& - 11849659, 11849659, 11849671, 11849671, 11849683, 11849683,& - 11849689, 11849689, 11849693, 11849693, 11849699, 11849699,& - 11849701, 11849701, 11849707, 11849707, 11849713, 11849713,& - 11849723, 11849723, 11849741, 11849741, 11849743, 11849743,& - 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / - data (iparam(1,i),iparam(2,i),i= 120, 149) / & - 11849791, 11849791, 11849801, 11849801, 11849809, 11849809,& - 11849813, 11849813, 11849869, 11849869, 11849881, 11849881,& - 11849891, 11849891, 11849909, 11849909, 11849923, 11849923,& - 11849933, 11849933, 11849947, 11849947, 11849987, 11849987,& - 11850001, 11850001, 11850011, 11850011, 11850019, 11850019,& - 11850023, 11850023, 11850031, 11850031, 11850049, 11850049,& - 11850061, 11850061, 11850073, 11850073, 11850077, 11850077,& - 11850103, 11850103, 11850109, 11850109, 11850121, 11850121,& - 11850127, 11850127, 11850133, 11850133, 11850149, 11850149,& - 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / - data (iparam(1,i),iparam(2,i),i= 150, 179) / & - 11850233, 11850233, 11850247, 11850247, 11850259, 11850259,& - 11850269, 11850269, 11850283, 11850283, 11850301, 11850301,& - 11850341, 11850341, 11850347, 11850347, 11850367, 11850367,& - 11850373, 11850373, 11850379, 11850379, 11850389, 11850389,& - 11850407, 11850407, 11850427, 11850427, 11850437, 11850437,& - 11850469, 11850469, 11850481, 11850481, 11850511, 11850511,& - 11850529, 11850529, 11850541, 11850541, 11850557, 11850557,& - 11850607, 11850607, 11850611, 11850611, 11850667, 11850667,& - 11850677, 11850677, 11850679, 11850679, 11850701, 11850701,& - 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / - data (iparam(1,i),iparam(2,i),i= 180, 209) / & - 11850791, 11850791, 11850803, 11850803, 11850829, 11850829,& - 11850833, 11850833, 11850859, 11850859, 11850877, 11850877,& - 11850899, 11850899, 11850907, 11850907, 11850913, 11850913,& - 11850919, 11850919, 11850931, 11850931, 11850941, 11850941,& - 11850947, 11850947, 11850953, 11850953, 11850961, 11850961,& - 11850983, 11850983, 11850991, 11850991, 11850997, 11850997,& - 11851031, 11851031, 11851033, 11851033, 11851051, 11851051,& - 11851061, 11851061, 11851067, 11851067, 11851093, 11851093,& - 11851109, 11851109, 11851123, 11851123, 11851127, 11851127,& - 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / - data (iparam(1,i),iparam(2,i),i= 210, 239) / & - 11851181, 11851181, 11851201, 11851201, 11851219, 11851219,& - 11851291, 11851291, 11851303, 11851303, 11851309, 11851309,& - 11851313, 11851313, 11851319, 11851319, 11851349, 11851349,& - 11851351, 11851351, 11851361, 11851361, 11851373, 11851373,& - 11851403, 11851403, 11851409, 11851409, 11851423, 11851423,& - 11851447, 11851447, 11851451, 11851451, 11851481, 11851481,& - 11851493, 11851493, 11851519, 11851519, 11851523, 11851523,& - 11851529, 11851529, 11851547, 11851547, 11851549, 11851549,& - 11851559, 11851559, 11851577, 11851577, 11851589, 11851589,& - 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / - data (iparam(1,i),iparam(2,i),i= 240, 269) / & - 11851607, 11851607, 11851613, 11851613, 11851621, 11851621,& - 11851627, 11851627, 11851639, 11851639, 11851673, 11851673,& - 11851681, 11851681, 11851727, 11851727, 11851753, 11851753,& - 11851759, 11851759, 11851787, 11851787, 11851793, 11851793,& - 11851799, 11851799, 11851813, 11851813, 11851841, 11851841,& - 11851859, 11851859, 11851867, 11851867, 11851891, 11851891,& - 11851909, 11851909, 11851919, 11851919, 11851927, 11851927,& - 11851933, 11851933, 11851949, 11851949, 11851967, 11851967,& - 11851997, 11851997, 11852017, 11852017, 11852051, 11852051,& - 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / - data (iparam(1,i),iparam(2,i),i= 270, 299) / & - 11852089, 11852089, 11852129, 11852129, 11852147, 11852147,& - 11852149, 11852149, 11852161, 11852161, 11852171, 11852171,& - 11852177, 11852177, 11852209, 11852209, 11852221, 11852221,& - 11852237, 11852237, 11852251, 11852251, 11852263, 11852263,& - 11852273, 11852273, 11852279, 11852279, 11852287, 11852287,& - 11852293, 11852293, 11852297, 11852297, 11852303, 11852303,& - 11852311, 11852311, 11852327, 11852327, 11852339, 11852339,& - 11852341, 11852341, 11852359, 11852359, 11852369, 11852369,& - 11852437, 11852437, 11852453, 11852453, 11852459, 11852459,& - 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / - data (iparam(1,i),iparam(2,i),i= 300, 329) / & - 11852537, 11852537, 11852539, 11852539, 11852557, 11852557,& - 11852573, 11852573, 11852579, 11852579, 11852591, 11852591,& - 11852609, 11852609, 11852611, 11852611, 11852623, 11852623,& - 11852641, 11852641, 11852647, 11852647, 11852657, 11852657,& - 11852663, 11852663, 11852717, 11852717, 11852719, 11852719,& - 11852741, 11852741, 11852759, 11852759, 11852767, 11852767,& - 11852773, 11852773, 11852803, 11852803, 11852807, 11852807,& - 11852809, 11852809, 11852831, 11852831, 11852833, 11852833,& - 11852837, 11852837, 11852857, 11852857, 11852873, 11852873,& - 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / - data (iparam(1,i),iparam(2,i),i= 330, 359) / & - 11852921, 11852921, 11852957, 11852957, 11852959, 11852959,& - 11852969, 11852969, 11852983, 11852983, 11852989, 11852989,& - 11853001, 11853001, 11853013, 11853013, 11853019, 11853019,& - 11853031, 11853031, 11853089, 11853089, 11853133, 11853133,& - 11853157, 11853157, 11853161, 11853161, 11853181, 11853181,& - 11853203, 11853203, 11853217, 11853217, 11853221, 11853221,& - 11853227, 11853227, 11853241, 11853241, 11853307, 11853307,& - 11853319, 11853319, 11853323, 11853323, 11853329, 11853329,& - 11853367, 11853367, 11853383, 11853383, 11853419, 11853419,& - 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / - data (iparam(1,i),iparam(2,i),i= 360, 389) / & - 11853451, 11853451, 11853463, 11853463, 11853529, 11853529,& - 11853557, 11853557, 11853571, 11853571, 11853601, 11853601,& - 11853613, 11853613, 11853617, 11853617, 11853629, 11853629,& - 11853649, 11853649, 11853659, 11853659, 11853679, 11853679,& - 11853689, 11853689, 11853719, 11853719, 11853731, 11853731,& - 11853757, 11853757, 11853761, 11853761, 11853773, 11853773,& - 11853791, 11853791, 11853817, 11853817, 11853839, 11853839,& - 11853847, 11853847, 11853857, 11853857, 11853869, 11853869,& - 11853883, 11853883, 11853887, 11853887, 11853889, 11853889,& - 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / - data (iparam(1,i),iparam(2,i),i= 390, 419) / & - 11853931, 11853931, 11853943, 11853943, 11853979, 11853979,& - 11853991, 11853991, 11854001, 11854001, 11854009, 11854009,& - 11854019, 11854019, 11854057, 11854057, 11854061, 11854061,& - 11854147, 11854147, 11854159, 11854159, 11854163, 11854163,& - 11854169, 11854169, 11854211, 11854211, 11854247, 11854247,& - 11854261, 11854261, 11854267, 11854267, 11854279, 11854279,& - 11854303, 11854303, 11854327, 11854327, 11854331, 11854331,& - 11854333, 11854333, 11854363, 11854363, 11854379, 11854379,& - 11854399, 11854399, 11854411, 11854411, 11854429, 11854429,& - 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / - data (iparam(1,i),iparam(2,i),i= 420, 449) / & - 11854463, 11854463, 11854477, 11854477, 11854489, 11854489,& - 11854517, 11854517, 11854519, 11854519, 11854523, 11854523,& - 11854529, 11854529, 11854567, 11854567, 11854571, 11854571,& - 11854573, 11854573, 11854603, 11854603, 11854607, 11854607,& - 11854681, 11854681, 11854691, 11854691, 11854709, 11854709,& - 11854723, 11854723, 11854757, 11854757, 11854783, 11854783,& - 11854793, 11854793, 11854813, 11854813, 11854847, 11854847,& - 11854853, 11854853, 11854873, 11854873, 11854877, 11854877,& - 11854883, 11854883, 11854891, 11854891, 11854897, 11854897,& - 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / - data (iparam(1,i),iparam(2,i),i= 450, 479) / & - 11854961, 11854961, 11854963, 11854963, 11854979, 11854979,& - 11855003, 11855003, 11855017, 11855017, 11855023, 11855023,& - 11855029, 11855029, 11855033, 11855033, 11855111, 11855111,& - 11855141, 11855141, 11855147, 11855147, 11855149, 11855149,& - 11855159, 11855159, 11855177, 11855177, 11855203, 11855203,& - 11855213, 11855213, 11855219, 11855219, 11855231, 11855231,& - 11855267, 11855267, 11855269, 11855269, 11855303, 11855303,& - 11855309, 11855309, 11855321, 11855321, 11855329, 11855329,& - 11855339, 11855339, 11855351, 11855351, 11855353, 11855353,& - 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / - data (iparam(1,i),iparam(2,i),i= 480, 509) / & - 11855383, 11855383, 11855387, 11855387, 11855399, 11855399,& - 11855407, 11855407, 11855413, 11855413, 11855489, 11855489,& - 11855491, 11855491, 11855507, 11855507, 11855521, 11855521,& - 11855531, 11855531, 11855549, 11855549, 11855551, 11855551,& - 11855567, 11855567, 11855581, 11855581, 11855587, 11855587,& - 11855593, 11855593, 11855633, 11855633, 11855653, 11855653,& - 11855663, 11855663, 11855687, 11855687, 11855689, 11855689,& - 11855699, 11855699, 11855713, 11855713, 11855731, 11855731,& - 11855737, 11855737, 11855743, 11855743, 11855747, 11855747,& - 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / - data (iparam(1,i),iparam(2,i),i= 510, 539) / & - 11855807, 11855807, 11855813, 11855813, 11855827, 11855827,& - 11855839, 11855839, 11855869, 11855869, 11855881, 11855881,& - 11855903, 11855903, 11855911, 11855911, 11855933, 11855933,& - 11855959, 11855959, 11855989, 11855989, 11855993, 11855993,& - 11855999, 11855999, 11856001, 11856001, 11856023, 11856023,& - 11856049, 11856049, 11856071, 11856071, 11856101, 11856101,& - 11856107, 11856107, 11856113, 11856113, 11856139, 11856139,& - 11856151, 11856151, 11856161, 11856161, 11856179, 11856179,& - 11856193, 11856193, 11856199, 11856199, 11856223, 11856223,& - 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / - data (iparam(1,i),iparam(2,i),i= 540, 569) / & - 11856281, 11856281, 11856287, 11856287, 11856307, 11856307,& - 11856311, 11856311, 11856329, 11856329, 11856343, 11856343,& - 11856359, 11856359, 11856371, 11856371, 11856373, 11856373,& - 11856409, 11856409, 11856419, 11856419, 11856461, 11856461,& - 11856469, 11856469, 11856473, 11856473, 11856479, 11856479,& - 11856511, 11856511, 11856517, 11856517, 11856541, 11856541,& - 11856547, 11856547, 11856553, 11856553, 11856583, 11856583,& - 11856629, 11856629, 11856641, 11856641, 11856653, 11856653,& - 11856659, 11856659, 11856673, 11856673, 11856697, 11856697,& - 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / - data (iparam(1,i),iparam(2,i),i= 570, 599) / & - 11856763, 11856763, 11856809, 11856809, 11856811, 11856811,& - 11856821, 11856821, 11856841, 11856841, 11856857, 11856857,& - 11856877, 11856877, 11856883, 11856883, 11856899, 11856899,& - 11856919, 11856919, 11856947, 11856947, 11856953, 11856953,& - 11856979, 11856979, 11857003, 11857003, 11857033, 11857033,& - 11857037, 11857037, 11857039, 11857039, 11857049, 11857049,& - 11857061, 11857061, 11857067, 11857067, 11857073, 11857073,& - 11857081, 11857081, 11857091, 11857091, 11857093, 11857093,& - 11857099, 11857099, 11857123, 11857123, 11857127, 11857127,& - 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / - data (iparam(1,i),iparam(2,i),i= 600, 629) / & - 11857217, 11857217, 11857229, 11857229, 11857243, 11857243,& - 11857249, 11857249, 11857267, 11857267, 11857277, 11857277,& - 11857291, 11857291, 11857303, 11857303, 11857309, 11857309,& - 11857327, 11857327, 11857331, 11857331, 11857333, 11857333,& - 11857361, 11857361, 11857367, 11857367, 11857369, 11857369,& - 11857393, 11857393, 11857399, 11857399, 11857409, 11857409,& - 11857421, 11857421, 11857423, 11857423, 11857451, 11857451,& - 11857453, 11857453, 11857457, 11857457, 11857477, 11857477,& - 11857481, 11857481, 11857493, 11857493, 11857499, 11857499,& - 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / - data (iparam(1,i),iparam(2,i),i= 630, 659) / & - 11857543, 11857543, 11857561, 11857561, 11857589, 11857589,& - 11857591, 11857591, 11857613, 11857613, 11857621, 11857621,& - 11857661, 11857661, 11857667, 11857667, 11857693, 11857693,& - 11857697, 11857697, 11857709, 11857709, 11857711, 11857711,& - 11857751, 11857751, 11857753, 11857753, 11857759, 11857759,& - 11857763, 11857763, 11857777, 11857777, 11857787, 11857787,& - 11857793, 11857793, 11857801, 11857801, 11857817, 11857817,& - 11857819, 11857819, 11857831, 11857831, 11857837, 11857837,& - 11857873, 11857873, 11857877, 11857877, 11857883, 11857883,& - 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / - data (iparam(1,i),iparam(2,i),i= 660, 689) / & - 11857931, 11857931, 11857969, 11857969, 11857991, 11857991,& - 11857999, 11857999, 11858009, 11858009, 11858017, 11858017,& - 11858023, 11858023, 11858029, 11858029, 11858039, 11858039,& - 11858051, 11858051, 11858057, 11858057, 11858059, 11858059,& - 11858101, 11858101, 11858111, 11858111, 11858131, 11858131,& - 11858149, 11858149, 11858159, 11858159, 11858177, 11858177,& - 11858191, 11858191, 11858201, 11858201, 11858227, 11858227,& - 11858243, 11858243, 11858267, 11858267, 11858269, 11858269,& - 11858279, 11858279, 11858281, 11858281, 11858291, 11858291,& - 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / - data (iparam(1,i),iparam(2,i),i= 690, 719) / & - 11858377, 11858377, 11858381, 11858381, 11858387, 11858387,& - 11858423, 11858423, 11858443, 11858443, 11858447, 11858447,& - 11858479, 11858479, 11858533, 11858533, 11858543, 11858543,& - 11858551, 11858551, 11858557, 11858557, 11858569, 11858569,& - 11858573, 11858573, 11858579, 11858579, 11858597, 11858597,& - 11858599, 11858599, 11858629, 11858629, 11858657, 11858657,& - 11858659, 11858659, 11858683, 11858683, 11858701, 11858701,& - 11858719, 11858719, 11858723, 11858723, 11858729, 11858729,& - 11858747, 11858747, 11858779, 11858779, 11858783, 11858783,& - 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / - data (iparam(1,i),iparam(2,i),i= 720, 749) / & - 11858839, 11858839, 11858851, 11858851, 11858893, 11858893,& - 11858897, 11858897, 11858921, 11858921, 11858947, 11858947,& - 11858953, 11858953, 11858969, 11858969, 11858971, 11858971,& - 11858989, 11858989, 11859017, 11859017, 11859031, 11859031,& - 11859049, 11859049, 11859061, 11859061, 11859073, 11859073,& - 11859077, 11859077, 11859079, 11859079, 11859083, 11859083,& - 11859101, 11859101, 11859109, 11859109, 11859137, 11859137,& - 11859139, 11859139, 11859151, 11859151, 11859157, 11859157,& - 11859163, 11859163, 11859167, 11859167, 11859179, 11859179,& - 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / - data (iparam(1,i),iparam(2,i),i= 750, 779) / & - 11859241, 11859241, 11859247, 11859247, 11859269, 11859269,& - 11859293, 11859293, 11859307, 11859307, 11859311, 11859311,& - 11859349, 11859349, 11859359, 11859359, 11859371, 11859371,& - 11859377, 11859377, 11859383, 11859383, 11859427, 11859427,& - 11859433, 11859433, 11859451, 11859451, 11859457, 11859457,& - 11859461, 11859461, 11859473, 11859473, 11859481, 11859481,& - 11859487, 11859487, 11859493, 11859493, 11859503, 11859503,& - 11859509, 11859509, 11859539, 11859539, 11859541, 11859541,& - 11859563, 11859563, 11859569, 11859569, 11859571, 11859571,& - 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / - data (iparam(1,i),iparam(2,i),i= 780, 809) / & - 11859643, 11859643, 11859707, 11859707, 11859713, 11859713,& - 11859719, 11859719, 11859739, 11859739, 11859751, 11859751,& - 11859791, 11859791, 11859817, 11859817, 11859821, 11859821,& - 11859833, 11859833, 11859847, 11859847, 11859853, 11859853,& - 11859877, 11859877, 11859889, 11859889, 11859893, 11859893,& - 11859901, 11859901, 11859907, 11859907, 11859917, 11859917,& - 11859923, 11859923, 11859929, 11859929, 11859961, 11859961,& - 11859979, 11859979, 11859989, 11859989, 11859997, 11859997,& - 11860021, 11860021, 11860031, 11860031, 11860039, 11860039,& - 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / - data (iparam(1,i),iparam(2,i),i= 810, 839) / & - 11860097, 11860097, 11860103, 11860103, 11860109, 11860109,& - 11860117, 11860117, 11860133, 11860133, 11860151, 11860151,& - 11860171, 11860171, 11860207, 11860207, 11860223, 11860223,& - 11860231, 11860231, 11860243, 11860243, 11860267, 11860267,& - 11860301, 11860301, 11860307, 11860307, 11860327, 11860327,& - 11860379, 11860379, 11860397, 11860397, 11860411, 11860411,& - 11860469, 11860469, 11860477, 11860477, 11860483, 11860483,& - 11860487, 11860487, 11860489, 11860489, 11860493, 11860493,& - 11860517, 11860517, 11860547, 11860547, 11860567, 11860567,& - 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / - data (iparam(1,i),iparam(2,i),i= 840, 869) / & - 11860627, 11860627, 11860637, 11860637, 11860643, 11860643,& - 11860649, 11860649, 11860661, 11860661, 11860669, 11860669,& - 11860687, 11860687, 11860691, 11860691, 11860697, 11860697,& - 11860699, 11860699, 11860703, 11860703, 11860727, 11860727,& - 11860741, 11860741, 11860753, 11860753, 11860777, 11860777,& - 11860787, 11860787, 11860789, 11860789, 11860811, 11860811,& - 11860837, 11860837, 11860859, 11860859, 11860867, 11860867,& - 11860889, 11860889, 11860897, 11860897, 11860963, 11860963,& - 11860969, 11860969, 11860973, 11860973, 11860993, 11860993,& - 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / - data (iparam(1,i),iparam(2,i),i= 870, 899) / & - 11861081, 11861081, 11861089, 11861089, 11861093, 11861093,& - 11861099, 11861099, 11861107, 11861107, 11861131, 11861131,& - 11861141, 11861141, 11861159, 11861159, 11861167, 11861167,& - 11861191, 11861191, 11861197, 11861197, 11861207, 11861207,& - 11861219, 11861219, 11861221, 11861221, 11861231, 11861231,& - 11861237, 11861237, 11861273, 11861273, 11861293, 11861293,& - 11861299, 11861299, 11861303, 11861303, 11861327, 11861327,& - 11861351, 11861351, 11861357, 11861357, 11861363, 11861363,& - 11861371, 11861371, 11861401, 11861401, 11861407, 11861407,& - 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / - data (iparam(1,i),iparam(2,i),i= 900, 929) / & - 11861441, 11861441, 11861467, 11861467, 11861527, 11861527,& - 11861539, 11861539, 11861543, 11861543, 11861557, 11861557,& - 11861569, 11861569, 11861573, 11861573, 11861579, 11861579,& - 11861581, 11861581, 11861599, 11861599, 11861611, 11861611,& - 11861617, 11861617, 11861627, 11861627, 11861639, 11861639,& - 11861651, 11861651, 11861659, 11861659, 11861671, 11861671,& - 11861683, 11861683, 11861687, 11861687, 11861693, 11861693,& - 11861701, 11861701, 11861711, 11861711, 11861713, 11861713,& - 11861749, 11861749, 11861791, 11861791, 11861803, 11861803,& - 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / - data (iparam(1,i),iparam(2,i),i= 930, 959) / & - 11861873, 11861873, 11861879, 11861879, 11861887, 11861887,& - 11861911, 11861911, 11861917, 11861917, 11861921, 11861921,& - 11861923, 11861923, 11861953, 11861953, 11861959, 11861959,& - 11861987, 11861987, 11862007, 11862007, 11862013, 11862013,& - 11862029, 11862029, 11862031, 11862031, 11862049, 11862049,& - 11862077, 11862077, 11862083, 11862083, 11862157, 11862157,& - 11862167, 11862167, 11862199, 11862199, 11862203, 11862203,& - 11862217, 11862217, 11862223, 11862223, 11862229, 11862229,& - 11862233, 11862233, 11862239, 11862239, 11862241, 11862241,& - 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / - data (iparam(1,i),iparam(2,i),i= 960, 989) / & - 11862293, 11862293, 11862307, 11862307, 11862313, 11862313,& - 11862317, 11862317, 11862343, 11862343, 11862353, 11862353,& - 11862373, 11862373, 11862391, 11862391, 11862439, 11862439,& - 11862469, 11862469, 11862493, 11862493, 11862527, 11862527,& - 11862547, 11862547, 11862563, 11862563, 11862569, 11862569,& - 11862577, 11862577, 11862581, 11862581, 11862611, 11862611,& - 11862623, 11862623, 11862661, 11862661, 11862673, 11862673,& - 11862679, 11862679, 11862701, 11862701, 11862703, 11862703,& - 11862713, 11862713, 11862761, 11862761, 11862791, 11862791,& - 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / - data (iparam(1,i),iparam(2,i),i= 990,1019) / & - 11862857, 11862857, 11862869, 11862869, 11862881, 11862881,& - 11862911, 11862911, 11862919, 11862919, 11862959, 11862959,& - 11862979, 11862979, 11862989, 11862989, 11862997, 11862997,& - 11863021, 11863021, 11863031, 11863031, 11863037, 11863037,& - 11863039, 11863039, 11863057, 11863057, 11863067, 11863067,& - 11863073, 11863073, 11863099, 11863099, 11863109, 11863109,& - 11863121, 11863121, 11863123, 11863123, 11863133, 11863133,& - 11863151, 11863151, 11863153, 11863153, 11863171, 11863171,& - 11863183, 11863183, 11863207, 11863207, 11863213, 11863213,& - 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / - data (iparam(1,i),iparam(2,i),i=1020,1021) / & - 11863259, 11863259, 11863279, 11863279 / -! end -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! prng.f -!----------------------------------------------------------------------------- - real(kind=8) function prng_next(me) -! implicit none - integer :: me -! -! Calling sequence: -! = prng_next ( ) -! = vprng ( , , ) -! -! This code is based on a sequential algorithm provided by Mal Kalos. -! This version uses a single 64-bit word to store the initial seeds -! and additive constants. -! A 64-bit floating point number is returned. -! -! The array "iparam" is full-word aligned, being padded by zeros to -! let each generator be on a subpage boundary. -! That is, rows 1 and 2 in a given column of the array are for real, -! rows 3-16 are bogus. -! -! July 12, 1993: double the number of sequences. We should have been -! using two packets per seed, rather than four -! October 31, 1993: merge the two arrays of seeds and constants, -! and switch to 64-bit arithmetic. -! June 1994: port to RS6K. Internal state is kept as 2 64-bit integers -! The ishft function is defined only on 32-bit integers, so we will -! shift numbers by dividing by 2**11 and then adding on 2**53-1. -! -! November 1994: ishift now works on 64-bit numbers (though it gives a -! warning). Thus we go back to using it. John Zollweg also added the -! vprng() routine to return vectors of real*8 random numbers. -! - real(kind=8),parameter :: recip53 = 2.0D0**(-53) - integer(kind=8),parameter :: two = 2**11 - integer(kind=8) :: m,ishift -! parameter ( m = 34522712143931 ) ! 11**13 -! parameter ( ishift = 9007199254740991 ) ! 2**53-1 - -!EL integer,parameter :: nmax = 1021 -!EL integer(kind=8) :: iparam -!EL common/ksrprng/iparam(2,0:nmax) - - integer(kind=8) :: next - -!rc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - ishift = dint(9007199254740991.0d0) - -! RS6K porting note: ishift now takes 64-bit integers , with a warning - if ( 0.le.me .and. me.le.nmax ) then - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - prng_next = recip53 * ishft( next, -11 ) - else - prng_next=-1.0D0 - endif - - end function prng_next -!----------------------------------------------------------------------------- - subroutine vprng(me,rn,num) - - real(kind=8),parameter :: recip53 = 2.0D0**(-53) - real(kind=8),dimension(1) :: rn - integer(kind=8) :: m -!EL,iparam -! parameter ( m = 34522712143931 ) ! 11**13 -!EL integer,parameter :: nmax=1021 - integer :: num, me,i - -!EL common/ksrprng/iparam(2,0:nmax) - - integer(kind=8) :: next - -!rc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - - if ( 0.le.me .and. me.le.nmax ) then - do 1 i=1,num - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - rn(i) = recip53 * ishft( next, -11 ) - 1 continue - else - rn(1)=-1.0D0 - endif - return - end subroutine vprng -!----------------------------------------------------------------------------- -! -! prng_chkpnt Get the current state of a generator -! -! Calling sequence: -! logical prng_chkpnt, status -! status = prng_chkpnt (me, iseed) where -! -! me is the particular generator whose state is being gotten -! seed is an 4-element integer array where the "l"-values will be saved -! - logical function prng_chkpnt(me,iseed) -! implicit none - integer :: me - integer(kind=8) :: iseed - -!EL integer,parameter :: nmax=1021 -!EL integer(kind=8) :: iparam -!EL common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed=iparam(1,me) - endif - end function prng_chkpnt -!----------------------------------------------------------------------------- -! -! prng_restart Restart generator from a saved state -! -! Calling sequence: -! logical prng_restart, status -! status = prng_restart (me, iseed) where -! -! me is the particular generator being restarted -! iseed is a 8-byte integer containing the "l"-values -! - logical function prng_restart(me,iseed) -! implicit none - integer :: me - integer(kind=8) :: iseed - -!EL integer,parameter :: nmax=1021 -!EL integer(kind=8) :: iparam -!EL common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - iparam(1,me)=iseed - endif - end function prng_restart -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module prng diff --git a/source/unres/prng_32.F90 b/source/unres/prng_32.F90 new file mode 100644 index 0000000..a991715 --- /dev/null +++ b/source/unres/prng_32.F90 @@ -0,0 +1,1102 @@ + module prng + implicit none +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! +#if defined(AIX) || defined(AMD64) +! block data prngblk + integer,parameter :: nmax=1021 + integer(kind=8),dimension(2,0:nmax) :: iparam +! common/ksrprng/iparam(2,0:nmax) + integer,private :: i,j + data (iparam(1,i),iparam(2,i),i= 0, 29) / & + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241,& + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271,& + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339,& + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363,& + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379,& + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451,& + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489,& + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523,& + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553,& + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / + data (iparam(1,i),iparam(2,i),i= 30, 59) / & + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663,& + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691,& + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717,& + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741,& + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787,& + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853,& + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873,& + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919,& + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961,& + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / + data (iparam(1,i),iparam(2,i),i= 60, 89) / & + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069,& + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093,& + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129,& + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183,& + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237,& + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251,& + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291,& + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339,& + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399,& + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / + data (iparam(1,i),iparam(2,i),i= 90, 119) / & + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473,& + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507,& + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569,& + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599,& + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653,& + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683,& + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699,& + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713,& + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743,& + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / + data (iparam(1,i),iparam(2,i),i= 120, 149) / & + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809,& + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881,& + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923,& + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987,& + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019,& + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049,& + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077,& + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121,& + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149,& + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / + data (iparam(1,i),iparam(2,i),i= 150, 179) / & + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259,& + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301,& + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367,& + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389,& + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437,& + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511,& + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557,& + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667,& + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701,& + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / + data (iparam(1,i),iparam(2,i),i= 180, 209) / & + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829,& + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877,& + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913,& + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941,& + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961,& + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997,& + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051,& + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093,& + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127,& + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / + data (iparam(1,i),iparam(2,i),i= 210, 239) / & + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219,& + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309,& + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349,& + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373,& + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423,& + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481,& + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523,& + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549,& + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589,& + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / + data (iparam(1,i),iparam(2,i),i= 240, 269) / & + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621,& + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673,& + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753,& + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793,& + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841,& + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891,& + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927,& + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967,& + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051,& + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / + data (iparam(1,i),iparam(2,i),i= 270, 299) / & + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147,& + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171,& + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221,& + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263,& + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287,& + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303,& + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339,& + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369,& + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459,& + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / + data (iparam(1,i),iparam(2,i),i= 300, 329) / & + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557,& + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591,& + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623,& + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657,& + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719,& + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767,& + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807,& + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833,& + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873,& + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / + data (iparam(1,i),iparam(2,i),i= 330, 359) / & + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959,& + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989,& + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019,& + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133,& + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181,& + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221,& + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307,& + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329,& + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419,& + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / + data (iparam(1,i),iparam(2,i),i= 360, 389) / & + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529,& + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601,& + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629,& + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679,& + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731,& + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773,& + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839,& + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869,& + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889,& + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / + data (iparam(1,i),iparam(2,i),i= 390, 419) / & + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979,& + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009,& + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061,& + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163,& + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247,& + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279,& + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331,& + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379,& + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429,& + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / + data (iparam(1,i),iparam(2,i),i= 420, 449) / & + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489,& + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523,& + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571,& + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607,& + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709,& + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783,& + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847,& + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877,& + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897,& + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / + data (iparam(1,i),iparam(2,i),i= 450, 479) / & + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979,& + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023,& + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111,& + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149,& + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203,& + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231,& + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303,& + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329,& + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353,& + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / + data (iparam(1,i),iparam(2,i),i= 480, 509) / & + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399,& + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489,& + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521,& + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551,& + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587,& + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653,& + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689,& + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731,& + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747,& + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / + data (iparam(1,i),iparam(2,i),i= 510, 539) / & + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827,& + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881,& + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933,& + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993,& + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023,& + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101,& + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139,& + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179,& + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223,& + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / + data (iparam(1,i),iparam(2,i),i= 540, 569) / & + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307,& + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343,& + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373,& + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461,& + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479,& + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541,& + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583,& + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653,& + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697,& + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / + data (iparam(1,i),iparam(2,i),i= 570, 599) / & + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811,& + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857,& + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899,& + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953,& + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033,& + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049,& + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073,& + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093,& + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127,& + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / + data (iparam(1,i),iparam(2,i),i= 600, 629) / & + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243,& + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277,& + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309,& + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333,& + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369,& + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409,& + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451,& + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477,& + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499,& + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / + data (iparam(1,i),iparam(2,i),i= 630, 659) / & + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589,& + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621,& + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693,& + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711,& + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759,& + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787,& + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817,& + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837,& + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883,& + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / + data (iparam(1,i),iparam(2,i),i= 660, 689) / & + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991,& + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017,& + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039,& + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059,& + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131,& + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177,& + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227,& + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269,& + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291,& + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / + data (iparam(1,i),iparam(2,i),i= 690, 719) / & + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387,& + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447,& + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543,& + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569,& + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597,& + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657,& + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701,& + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729,& + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783,& + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / + data (iparam(1,i),iparam(2,i),i= 720, 749) / & + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893,& + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947,& + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971,& + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031,& + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073,& + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083,& + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137,& + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157,& + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179,& + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / + data (iparam(1,i),iparam(2,i),i= 750, 779) / & + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269,& + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311,& + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371,& + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427,& + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457,& + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481,& + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503,& + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541,& + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571,& + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / + data (iparam(1,i),iparam(2,i),i= 780, 809) / & + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713,& + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751,& + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821,& + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853,& + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893,& + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917,& + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961,& + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997,& + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039,& + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / + data (iparam(1,i),iparam(2,i),i= 810, 839) / & + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109,& + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151,& + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223,& + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267,& + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327,& + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411,& + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483,& + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493,& + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567,& + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / + data (iparam(1,i),iparam(2,i),i= 840, 869) / & + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643,& + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669,& + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697,& + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727,& + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777,& + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811,& + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867,& + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963,& + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993,& + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / + data (iparam(1,i),iparam(2,i),i= 870, 899) / & + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093,& + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131,& + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167,& + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207,& + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231,& + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293,& + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327,& + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363,& + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407,& + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / + data (iparam(1,i),iparam(2,i),i= 900, 929) / & + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527,& + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557,& + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579,& + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611,& + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639,& + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671,& + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693,& + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713,& + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803,& + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / + data (iparam(1,i),iparam(2,i),i= 930, 959) / & + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887,& + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921,& + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959,& + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013,& + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049,& + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157,& + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203,& + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229,& + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241,& + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / + data (iparam(1,i),iparam(2,i),i= 960, 989) / & + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313,& + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353,& + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439,& + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527,& + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569,& + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611,& + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673,& + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703,& + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791,& + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / + data (iparam(1,i),iparam(2,i),i= 990,1019) / & + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881,& + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959,& + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997,& + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037,& + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067,& + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109,& + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133,& + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171,& + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213,& + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / + data (iparam(1,i),iparam(2,i),i=1020,1021) / & + 11863259, 11863259, 11863279, 11863279 / +! end +!----------------------------------------------------------------------------- +#else +! block data prngblk +! +! Sequence of prime numbers represented as pairs of 16-bit integers +! modulo 2**16, obtained from Mal Kalos August 28, 1992. Only 98 +! continuation cards are allowed by ksr Fortran, so several DATA +! statements are used to initialize 1022 generators. +! +! @cornell university, 1992 +! + integer,parameter :: nmax=1021,nmax1=2*nmax+2 + integer,dimension(16,0:nmax) :: l,n + integer,private :: i,j +! common/ksrprng/l(16,0:nmax),n(16,0:nmax) +!*ksr*subpage /ksrprng/ + +! High order quads in arrays "l" and "n" are initialized to zero : rows 1-2 +! Rows 5-16 remain uninitialized. They are just pads, never used. + DATA ((l(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ + DATA ((n(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ + +! The rest of array "l" and "n" are initialized to a 20-bit seed + DATA ((l(i,j),i=3,4),j=0,489)/ & + 180, 51739,180, 51757,180, 51761,180, 51767,180,51773,& + 180, 51791,180, 51817,180, 51833,180, 51859,180, 51871,& + 180, 51877,180, 51883,180, 51887,180, 51893,180, 51899,& + 180, 51913,180, 51953,180, 51971,180, 51989,180, 51997,& + 180, 52009,180, 52013,180, 52033,180, 52043,180, 52051,& + 180, 52057,180, 52073,180, 52109,180, 52111,180, 52121,& + 180, 52139,180, 52157,180, 52183,180, 52193,180, 52199,& + 180, 52211,180, 52219,180, 52229,180, 52237,180, 52241,& + 180, 52249,180, 52261,180, 52271,180, 52277,180, 52307,& + 180, 52321,180, 52349,180, 52373,180, 52381,180, 52387,& + 180, 52393,180, 52411,180, 52429,180, 52439,180, 52451,& + 180, 52457,180, 52481,180, 52501,180, 52541,180, 52559,& + 180, 52573,180, 52579,180, 52589,180, 52597,180, 52607,& + 180, 52613,180, 52627,180, 52631,180, 52649,180, 52657,& + 180, 52697,180, 52703,180, 52723,180, 52751,180, 52757,& + 180, 52759,180, 52769,180, 52771,180, 52789,180, 52793,& + 180, 52811,180, 52817,180, 52829,180, 52859,180, 52879,& + 180, 52883,180, 52919,180, 52921,180, 52933,180, 52937,& + 180, 52957,180, 52963,180, 52993,180, 53011,180, 53023,& + 180, 53027,180, 53077,180, 53087,180, 53089,180, 53093,& + 180, 53107,180, 53119,180, 53153,180, 53161,180, 53173,& + 180, 53179,180, 53191,180, 53203,180, 53209,180, 53213,& + 180, 53219,180, 53221,180, 53227,180, 53233,180, 53243,& + 180, 53261,180, 53263,180, 53279,180, 53287,180, 53291,& + 180, 53311,180, 53321,180, 53329,180, 53333,180, 53389,& + 180, 53401,180, 53411,180, 53429,180, 53443,180, 53453,& + 180, 53467,180, 53507,180, 53521,180, 53531,180, 53539,& + 180, 53543,180, 53551,180, 53569,180, 53581,180, 53593,& + 180, 53597,180, 53623,180, 53629,180, 53641,180, 53647,& + 180, 53653,180, 53669,180, 53681,180, 53689,180, 53711,& + 180, 53753,180, 53767,180, 53779,180, 53789,180, 53803,& + 180, 53821,180, 53861,180, 53867,180, 53887,180, 53893,& + 180, 53899,180, 53909,180, 53927,180, 53947,180, 53957,& + 180, 53989,180, 54001,180, 54031,180, 54049,180, 54061,& + 180, 54077,180, 54127,180, 54131,180, 54187,180, 54197,& + 180, 54199,180, 54221,180, 54251,180, 54259,180, 54269,& + 180, 54311,180, 54323,180, 54349,180, 54353,180, 54379,& + 180, 54397,180, 54419,180, 54427,180, 54433,180, 54439,& + 180, 54451,180, 54461,180, 54467,180, 54473,180, 54481,& + 180, 54503,180, 54511,180, 54517,180, 54551,180, 54553,& + 180, 54571,180, 54581,180, 54587,180, 54613,180, 54629,& + 180, 54643,180, 54647,180, 54659,180, 54677,180, 54683,& + 180, 54701,180, 54721,180, 54739,180, 54811,180, 54823,& + 180, 54829,180, 54833,180, 54839,180, 54869,180, 54871,& + 180, 54881,180, 54893,180, 54923,180, 54929,180, 54943,& + 180, 54967,180, 54971,180, 55001,180, 55013,180, 55039,& + 180, 55043,180, 55049,180, 55067,180, 55069,180, 55079,& + 180, 55097,180, 55109,180, 55111,180, 55117,180, 55123,& + 180, 55127,180, 55133,180, 55141,180, 55147,180, 55159,& + 180, 55193,180, 55201,180, 55247,180, 55273,180, 55279,& + 180, 55307,180, 55313,180, 55319,180, 55333,180, 55361,& + 180, 55379,180, 55387,180, 55411,180, 55429,180, 55439,& + 180, 55447,180, 55453,180, 55469,180, 55487,180, 55517,& + 180, 55537,180, 55571,180, 55573,180, 55579,180, 55603,& + 180, 55609,180, 55649,180, 55667,180, 55669,180, 55681,& + 180, 55691,180, 55697,180, 55729,180, 55741,180, 55757,& + 180, 55771,180, 55783,180, 55793,180, 55799,180, 55807,& + 180, 55813,180, 55817,180, 55823,180, 55831,180, 55847,& + 180, 55859,180, 55861,180, 55879,180, 55889,180, 55957,& + 180, 55973,180, 55979,180, 55993,180, 56033,180, 56051,& + 180, 56057,180, 56059,180, 56077,180, 56093,180, 56099,& + 180, 56111,180, 56129,180, 56131,180, 56143,180, 56161,& + 180, 56167,180, 56177,180, 56183,180, 56237,180, 56239,& + 180, 56261,180, 56279,180, 56287,180, 56293,180, 56323,& + 180, 56327,180, 56329,180, 56351,180, 56353,180, 56357,& + 180, 56377,180, 56393,180, 56399,180, 56411,180, 56437,& + 180, 56441,180, 56477,180, 56479,180, 56489,180, 56503,& + 180, 56509,180, 56521,180, 56533,180, 56539,180, 56551,& + 180, 56609,180, 56653,180, 56677,180, 56681,180, 56701,& + 180, 56723,180, 56737,180, 56741,180, 56747,180, 56761,& + 180, 56827,180, 56839,180, 56843,180, 56849,180, 56887,& + 180, 56903,180, 56939,180, 56941,180, 56947,180, 56969,& + 180, 56971,180, 56983,180, 57049,180, 57077,180, 57091,& + 180, 57121,180, 57133,180, 57137,180, 57149,180, 57169,& + 180, 57179,180, 57199,180, 57209,180, 57239,180, 57251,& + 180, 57277,180, 57281,180, 57293,180, 57311,180, 57337,& + 180, 57359,180, 57367,180, 57377,180, 57389,180, 57403,& + 180, 57407,180, 57409,180, 57413,180, 57419,180, 57431,& + 180, 57451,180, 57463,180, 57499,180, 57511,180, 57521,& + 180, 57529,180, 57539,180, 57577,180, 57581,180, 57667,& + 180, 57679,180, 57683,180, 57689,180, 57731,180, 57767,& + 180, 57781,180, 57787,180, 57799,180, 57823,180, 57847,& + 180, 57851,180, 57853,180, 57883,180, 57899,180, 57919,& + 180, 57931,180, 57949,180, 57953,180, 57959,180, 57961,& + 180, 57983,180, 57997,180, 58009,180, 58037,180, 58039,& + 180, 58043,180, 58049,180, 58087,180, 58091,180, 58093,& + 180, 58123,180, 58127,180, 58201,180, 58211,180, 58229,& + 180, 58243,180, 58277,180, 58303,180, 58313,180, 58333,& + 180, 58367,180, 58373,180, 58393,180, 58397,180, 58403,& + 180, 58411,180, 58417,180, 58421,180, 58439,180, 58457,& + 180, 58481,180, 58483,180, 58499,180, 58523,180, 58537,& + 180, 58543,180, 58549,180, 58553,180, 58631,180, 58661,& + 180, 58667,180, 58669,180, 58679,180, 58697,180, 58723,& + 180, 58733,180, 58739,180, 58751,180, 58787,180, 58789,& + 180, 58823,180, 58829,180, 58841,180, 58849,180, 58859,& + 180, 58871,180, 58873,180, 58877,180, 58879,180, 58901,& + 180, 58903,180, 58907,180, 58919,180, 58927,180, 58933,& + 180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ + DATA ((l(i,j),i=3,4),j=490,979)/ & + 180, 59069,180, 59071,180, 59087,180, 59101,180, 59107,& + 180, 59113,180, 59153,180, 59173,180, 59183,180, 59207,& + 180, 59209,180, 59219,180, 59233,180, 59251,180, 59257,& + 180, 59263,180, 59267,180, 59279,180, 59293,180, 59321,& + 180, 59327,180, 59333,180, 59347,180, 59359,180, 59389,& + 180, 59401,180, 59423,180, 59431,180, 59453,180, 59479,& + 180, 59509,180, 59513,180, 59519,180, 59521,180, 59543,& + 180, 59569,180, 59591,180, 59621,180, 59627,180, 59633,& + 180, 59659,180, 59671,180, 59681,180, 59699,180, 59713,& + 180, 59719,180, 59743,180, 59759,180, 59783,180, 59789,& + 180, 59801,180, 59807,180, 59827,180, 59831,180, 59849,& + 180, 59863,180, 59879,180, 59891,180, 59893,180, 59929,& + 180, 59939,180, 59981,180, 59989,180, 59993,180, 59999,& + 180, 60031,180, 60037,180, 60061,180, 60067,180, 60073,& + 180, 60103,180, 60149,180, 60161,180, 60173,180, 60179,& + 180, 60193,180, 60217,180, 60229,180, 60247,180, 60251,& + 180, 60283,180, 60329,180, 60331,180, 60341,180, 60361,& + 180, 60377,180, 60397,180, 60403,180, 60419,180, 60439,& + 180, 60467,180, 60473,180, 60499,180, 60523,180, 60553,& + 180, 60557,180, 60559,180, 60569,180, 60581,180, 60587,& + 180, 60593,180, 60601,180, 60611,180, 60613,180, 60619,& + 180, 60643,180, 60647,180, 60667,180, 60671,180, 60713,& + 180, 60737,180, 60749,180, 60763,180, 60769,180, 60787,& + 180, 60797,180, 60811,180, 60823,180, 60829,180, 60847,& + 180, 60851,180, 60853,180, 60881,180, 60887,180, 60889,& + 180, 60913,180, 60919,180, 60929,180, 60941,180, 60943,& + 180, 60971,180, 60973,180, 60977,180, 60997,180, 61001,& + 180, 61013,180, 61019,180, 61039,180, 61043,180, 61049,& + 180, 61063,180, 61081,180, 61109,180, 61111,180, 61133,& + 180, 61141,180, 61181,180, 61187,180, 61213,180, 61217,& + 180, 61229,180, 61231,180, 61271,180, 61273,180, 61279,& + 180, 61283,180, 61297,180, 61307,180, 61313,180, 61321,& + 180, 61337,180, 61339,180, 61351,180, 61357,180, 61393,& + 180, 61397,180, 61403,180, 61409,180, 61427,180, 61433,& + 180, 61451,180, 61489,180, 61511,180, 61519,180, 61529,& + 180, 61537,180, 61543,180, 61549,180, 61559,180, 61571,& + 180, 61577,180, 61579,180, 61621,180, 61631,180, 61651,& + 180, 61669,180, 61679,180, 61697,180, 61711,180, 61721,& + 180, 61747,180, 61763,180, 61787,180, 61789,180, 61799,& + 180, 61801,180, 61811,180, 61831,180, 61843,180, 61879,& + 180, 61897,180, 61901,180, 61907,180, 61943,180, 61963,& + 180, 61967,180, 61999,180, 62053,180, 62063,180, 62071,& + 180, 62077,180, 62089,180, 62093,180, 62099,180, 62117,& + 180, 62119,180, 62149,180, 62177,180, 62179,180, 62203,& + 180, 62221,180, 62239,180, 62243,180, 62249,180, 62267,& + 180, 62299,180, 62303,180, 62321,180, 62327,180, 62333,& + 180, 62359,180, 62371,180, 62413,180, 62417,180, 62441,& + 180, 62467,180, 62473,180, 62489,180, 62491,180, 62509,& + 180, 62537,180, 62551,180, 62569,180, 62581,180, 62593,& + 180, 62597,180, 62599,180, 62603,180, 62621,180, 62629,& + 180, 62657,180, 62659,180, 62671,180, 62677,180, 62683,& + 180, 62687,180, 62699,180, 62707,180, 62749,180, 62753,& + 180, 62761,180, 62767,180, 62789,180, 62813,180, 62827,& + 180, 62831,180, 62869,180, 62879,180, 62891,180, 62897,& + 180, 62903,180, 62947,180, 62953,180, 62971,180, 62977,& + 180, 62981,180, 62993,180, 63001,180, 63007,180, 63013,& + 180, 63023,180, 63029,180, 63059,180, 63061,180, 63083,& + 180, 63089,180, 63091,180, 63103,180, 63119,180, 63131,& + 180, 63163,180, 63227,180, 63233,180, 63239,180, 63259,& + 180, 63271,180, 63311,180, 63337,180, 63341,180, 63353,& + 180, 63367,180, 63373,180, 63397,180, 63409,180, 63413,& + 180, 63421,180, 63427,180, 63437,180, 63443,180, 63449,& + 180, 63481,180, 63499,180, 63509,180, 63517,180, 63541,& + 180, 63551,180, 63559,180, 63569,180, 63601,180, 63607,& + 180, 63617,180, 63623,180, 63629,180, 63637,180, 63653,& + 180, 63671,180, 63691,180, 63727,180, 63743,180, 63751,& + 180, 63763,180, 63787,180, 63821,180, 63827,180, 63847,& + 180, 63899,180, 63917,180, 63931,180, 63989,180, 63997,& + 180, 64003,180, 64007,180, 64009,180, 64013,180, 64037,& + 180, 64067,180, 64087,180, 64093,180, 64133,180, 64139,& + 180, 64147,180, 64157,180, 64163,180, 64169,180, 64181,& + 180, 64189,180, 64207,180, 64211,180, 64217,180, 64219,& + 180, 64223,180, 64247,180, 64261,180, 64273,180, 64297,& + 180, 64307,180, 64309,180, 64331,180, 64357,180, 64379,& + 180, 64387,180, 64409,180, 64417,180, 64483,180, 64489,& + 180, 64493,180, 64513,180, 64531,180, 64553,180, 64591,& + 180, 64601,180, 64609,180, 64613,180, 64619,180, 64627,& + 180, 64651,180, 64661,180, 64679,180, 64687,180, 64711,& + 180, 64717,180, 64727,180, 64739,180, 64741,180, 64751,& + 180, 64757,180, 64793,180, 64813,180, 64819,180, 64823,& + 180, 64847,180, 64871,180, 64877,180, 64883,180, 64891,& + 180, 64921,180, 64927,180, 64931,180, 64933,180, 64949,& + 180, 64961,180, 64987,180, 65047,180, 65059,180, 65063,& + 180, 65077,180, 65089,180, 65093,180, 65099,180, 65101,& + 180, 65119,180, 65131,180, 65137,180, 65147,180, 65159,& + 180, 65171,180, 65179,180, 65191,180, 65203,180, 65207,& + 180, 65213,180, 65221,180, 65231,180, 65233,180, 65269,& + 180, 65311,180, 65323,180, 65339,180, 65347,180, 65369,& + 180, 65393,180, 65399,180, 65407,180, 65431,180, 65437,& + 180, 65441,180, 65443,180, 65473,180, 65479,180, 65507,& + 180, 65527,180, 65533,181, 13,181, 15,181, 33,& + 181, 61,181, 67,181, 141,181, 151,181, 183,& + 181, 187,181, 201,181, 207,181, 213,181, 217,& + 181, 223,181, 225,181, 243,181, 253,181, 255,& + 181, 277,181, 291,181, 297,181, 301,181, 327,& + 181, 337,181, 357,181, 375,181, 423,181, 453,& + 181, 477,181, 511,181, 531,181, 547,181, 553,& + 181, 561,181, 565,181, 595,181, 607,181, 645/ + DATA ((l(i,j),i=3,4),j=980,nmax)/ & + 181, 657,181, 663,181, 685,181, 687,181, 697,& + 181, 745,181, 775,181, 787,181, 823,181, 825,& + 181, 841,181, 853,181, 865,181, 895,181, 903,& + 181, 943,181, 963,181, 973,181, 981,181, 1005,& + 181,1015,181,1021,181,1023,181,1041,181,1051,& + 181, 1057,181, 1083,181, 1093,181, 1105,181, 1107,& + 181, 1117,181, 1135,181, 1137,181, 1155,181, 1167,& + 181, 1191,181, 1197,181, 1221,181, 1233,181, 1237,& + 181, 1243,181, 1263/ + DATA ((n(i,j),i=3,4),j=0,489)/ & + 180, 51739,180, 51757,180, 51761,180, 51767,180, 51773,& + 180, 51791,180, 51817,180, 51833,180, 51859,180, 51871,& + 180, 51877,180, 51883,180, 51887,180, 51893,180, 51899,& + 180, 51913,180, 51953,180, 51971,180, 51989,180, 51997,& + 180, 52009,180, 52013,180, 52033,180, 52043,180, 52051,& + 180, 52057,180, 52073,180, 52109,180, 52111,180, 52121,& + 180, 52139,180, 52157,180, 52183,180, 52193,180, 52199,& + 180, 52211,180, 52219,180, 52229,180, 52237,180, 52241,& + 180, 52249,180, 52261,180, 52271,180, 52277,180, 52307,& + 180, 52321,180, 52349,180, 52373,180, 52381,180, 52387,& + 180, 52393,180, 52411,180, 52429,180, 52439,180, 52451,& + 180, 52457,180, 52481,180, 52501,180, 52541,180, 52559,& + 180, 52573,180, 52579,180, 52589,180, 52597,180, 52607,& + 180, 52613,180, 52627,180, 52631,180, 52649,180, 52657,& + 180, 52697,180, 52703,180, 52723,180, 52751,180, 52757,& + 180, 52759,180, 52769,180, 52771,180, 52789,180, 52793,& + 180, 52811,180, 52817,180, 52829,180, 52859,180, 52879,& + 180, 52883,180, 52919,180, 52921,180, 52933,180, 52937,& + 180, 52957,180, 52963,180, 52993,180, 53011,180, 53023,& + 180, 53027,180, 53077,180, 53087,180, 53089,180, 53093,& + 180, 53107,180, 53119,180, 53153,180, 53161,180, 53173,& + 180, 53179,180, 53191,180, 53203,180, 53209,180, 53213,& + 180, 53219,180, 53221,180, 53227,180, 53233,180, 53243,& + 180, 53261,180, 53263,180, 53279,180, 53287,180, 53291,& + 180, 53311,180, 53321,180, 53329,180, 53333,180, 53389,& + 180, 53401,180, 53411,180, 53429,180, 53443,180, 53453,& + 180, 53467,180, 53507,180, 53521,180, 53531,180, 53539,& + 180, 53543,180, 53551,180, 53569,180, 53581,180, 53593,& + 180, 53597,180, 53623,180, 53629,180, 53641,180, 53647,& + 180, 53653,180, 53669,180, 53681,180, 53689,180, 53711,& + 180, 53753,180, 53767,180, 53779,180, 53789,180, 53803,& + 180, 53821,180, 53861,180, 53867,180, 53887,180, 53893,& + 180, 53899,180, 53909,180, 53927,180, 53947,180, 53957,& + 180, 53989,180, 54001,180, 54031,180, 54049,180, 54061,& + 180, 54077,180, 54127,180, 54131,180, 54187,180, 54197,& + 180, 54199,180, 54221,180, 54251,180, 54259,180, 54269,& + 180, 54311,180, 54323,180, 54349,180, 54353,180, 54379,& + 180, 54397,180, 54419,180, 54427,180, 54433,180, 54439,& + 180, 54451,180, 54461,180, 54467,180, 54473,180, 54481,& + 180, 54503,180, 54511,180, 54517,180, 54551,180, 54553,& + 180, 54571,180, 54581,180, 54587,180, 54613,180, 54629,& + 180, 54643,180, 54647,180, 54659,180, 54677,180, 54683,& + 180, 54701,180, 54721,180, 54739,180, 54811,180, 54823,& + 180, 54829,180, 54833,180, 54839,180, 54869,180, 54871,& + 180, 54881,180, 54893,180, 54923,180, 54929,180, 54943,& + 180, 54967,180, 54971,180, 55001,180, 55013,180, 55039,& + 180, 55043,180, 55049,180, 55067,180, 55069,180, 55079,& + 180, 55097,180, 55109,180, 55111,180, 55117,180, 55123,& + 180, 55127,180, 55133,180, 55141,180, 55147,180, 55159,& + 180, 55193,180, 55201,180, 55247,180, 55273,180, 55279,& + 180, 55307,180, 55313,180, 55319,180, 55333,180, 55361,& + 180, 55379,180, 55387,180, 55411,180, 55429,180, 55439,& + 180, 55447,180, 55453,180, 55469,180, 55487,180, 55517,& + 180, 55537,180, 55571,180, 55573,180, 55579,180, 55603,& + 180, 55609,180, 55649,180, 55667,180, 55669,180, 55681,& + 180, 55691,180, 55697,180, 55729,180, 55741,180, 55757,& + 180, 55771,180, 55783,180, 55793,180, 55799,180, 55807,& + 180, 55813,180, 55817,180, 55823,180, 55831,180, 55847,& + 180, 55859,180, 55861,180, 55879,180, 55889,180, 55957,& + 180, 55973,180, 55979,180, 55993,180, 56033,180, 56051,& + 180, 56057,180, 56059,180, 56077,180, 56093,180, 56099,& + 180, 56111,180, 56129,180, 56131,180, 56143,180, 56161,& + 180, 56167,180, 56177,180, 56183,180, 56237,180, 56239,& + 180, 56261,180, 56279,180, 56287,180, 56293,180, 56323,& + 180, 56327,180, 56329,180, 56351,180, 56353,180, 56357,& + 180, 56377,180, 56393,180, 56399,180, 56411,180, 56437,& + 180, 56441,180, 56477,180, 56479,180, 56489,180, 56503,& + 180, 56509,180, 56521,180, 56533,180, 56539,180, 56551,& + 180, 56609,180, 56653,180, 56677,180, 56681,180, 56701,& + 180, 56723,180, 56737,180, 56741,180, 56747,180, 56761,& + 180, 56827,180, 56839,180, 56843,180, 56849,180, 56887,& + 180, 56903,180, 56939,180, 56941,180, 56947,180, 56969,& + 180, 56971,180, 56983,180, 57049,180, 57077,180, 57091,& + 180, 57121,180, 57133,180, 57137,180, 57149,180, 57169,& + 180, 57179,180, 57199,180, 57209,180, 57239,180, 57251,& + 180, 57277,180, 57281,180, 57293,180, 57311,180, 57337,& + 180, 57359,180, 57367,180, 57377,180, 57389,180, 57403,& + 180, 57407,180, 57409,180, 57413,180, 57419,180, 57431,& + 180, 57451,180, 57463,180, 57499,180, 57511,180, 57521,& + 180, 57529,180, 57539,180, 57577,180, 57581,180, 57667,& + 180, 57679,180, 57683,180, 57689,180, 57731,180, 57767,& + 180, 57781,180, 57787,180, 57799,180, 57823,180, 57847,& + 180, 57851,180, 57853,180, 57883,180, 57899,180, 57919,& + 180, 57931,180, 57949,180, 57953,180, 57959,180, 57961,& + 180, 57983,180, 57997,180, 58009,180, 58037,180, 58039,& + 180, 58043,180, 58049,180, 58087,180, 58091,180, 58093,& + 180, 58123,180, 58127,180, 58201,180, 58211,180, 58229,& + 180, 58243,180, 58277,180, 58303,180, 58313,180, 58333,& + 180, 58367,180, 58373,180, 58393,180, 58397,180, 58403,& + 180, 58411,180, 58417,180, 58421,180, 58439,180, 58457,& + 180, 58481,180, 58483,180, 58499,180, 58523,180, 58537,& + 180, 58543,180, 58549,180, 58553,180, 58631,180, 58661,& + 180, 58667,180, 58669,180, 58679,180, 58697,180, 58723,& + 180, 58733,180, 58739,180, 58751,180, 58787,180, 58789,& + 180, 58823,180, 58829,180, 58841,180, 58849,180, 58859,& + 180, 58871,180, 58873,180, 58877,180, 58879,180, 58901,& + 180, 58903,180, 58907,180, 58919,180, 58927,180, 58933,& + 180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ + DATA ((n(i,j),i=3,4),j=490,979)/ & + 180, 59069,180, 59071,180, 59087,180, 59101,180, 59107,& + 180, 59113,180, 59153,180, 59173,180, 59183,180, 59207,& + 180, 59209,180, 59219,180, 59233,180, 59251,180, 59257,& + 180, 59263,180, 59267,180, 59279,180, 59293,180, 59321,& + 180, 59327,180, 59333,180, 59347,180, 59359,180, 59389,& + 180, 59401,180, 59423,180, 59431,180, 59453,180, 59479,& + 180, 59509,180, 59513,180, 59519,180, 59521,180, 59543,& + 180, 59569,180, 59591,180, 59621,180, 59627,180, 59633,& + 180, 59659,180, 59671,180, 59681,180, 59699,180, 59713,& + 180, 59719,180, 59743,180, 59759,180, 59783,180, 59789,& + 180, 59801,180, 59807,180, 59827,180, 59831,180, 59849,& + 180, 59863,180, 59879,180, 59891,180, 59893,180, 59929,& + 180, 59939,180, 59981,180, 59989,180, 59993,180, 59999,& + 180, 60031,180, 60037,180, 60061,180, 60067,180, 60073,& + 180, 60103,180, 60149,180, 60161,180, 60173,180, 60179,& + 180, 60193,180, 60217,180, 60229,180, 60247,180, 60251,& + 180, 60283,180, 60329,180, 60331,180, 60341,180, 60361,& + 180, 60377,180, 60397,180, 60403,180, 60419,180, 60439,& + 180, 60467,180, 60473,180, 60499,180, 60523,180, 60553,& + 180, 60557,180, 60559,180, 60569,180, 60581,180, 60587,& + 180, 60593,180, 60601,180, 60611,180, 60613,180, 60619,& + 180, 60643,180, 60647,180, 60667,180, 60671,180, 60713,& + 180, 60737,180, 60749,180, 60763,180, 60769,180, 60787,& + 180, 60797,180, 60811,180, 60823,180, 60829,180, 60847,& + 180, 60851,180, 60853,180, 60881,180, 60887,180, 60889,& + 180, 60913,180, 60919,180, 60929,180, 60941,180, 60943,& + 180, 60971,180, 60973,180, 60977,180, 60997,180, 61001,& + 180, 61013,180, 61019,180, 61039,180, 61043,180, 61049,& + 180, 61063,180, 61081,180, 61109,180, 61111,180, 61133,& + 180, 61141,180, 61181,180, 61187,180, 61213,180, 61217,& + 180, 61229,180, 61231,180, 61271,180, 61273,180, 61279,& + 180, 61283,180, 61297,180, 61307,180, 61313,180, 61321,& + 180, 61337,180, 61339,180, 61351,180, 61357,180, 61393,& + 180, 61397,180, 61403,180, 61409,180, 61427,180, 61433,& + 180, 61451,180, 61489,180, 61511,180, 61519,180, 61529,& + 180, 61537,180, 61543,180, 61549,180, 61559,180, 61571,& + 180, 61577,180, 61579,180, 61621,180, 61631,180, 61651,& + 180, 61669,180, 61679,180, 61697,180, 61711,180, 61721,& + 180, 61747,180, 61763,180, 61787,180, 61789,180, 61799,& + 180, 61801,180, 61811,180, 61831,180, 61843,180, 61879,& + 180, 61897,180, 61901,180, 61907,180, 61943,180, 61963,& + 180, 61967,180, 61999,180, 62053,180, 62063,180, 62071,& + 180, 62077,180, 62089,180, 62093,180, 62099,180, 62117,& + 180, 62119,180, 62149,180, 62177,180, 62179,180, 62203,& + 180, 62221,180, 62239,180, 62243,180, 62249,180, 62267,& + 180, 62299,180, 62303,180, 62321,180, 62327,180, 62333,& + 180, 62359,180, 62371,180, 62413,180, 62417,180, 62441,& + 180, 62467,180, 62473,180, 62489,180, 62491,180, 62509,& + 180, 62537,180, 62551,180, 62569,180, 62581,180, 62593,& + 180, 62597,180, 62599,180, 62603,180, 62621,180, 62629,& + 180, 62657,180, 62659,180, 62671,180, 62677,180, 62683,& + 180, 62687,180, 62699,180, 62707,180, 62749,180, 62753,& + 180, 62761,180, 62767,180, 62789,180, 62813,180, 62827,& + 180, 62831,180, 62869,180, 62879,180, 62891,180, 62897,& + 180, 62903,180, 62947,180, 62953,180, 62971,180, 62977,& + 180, 62981,180, 62993,180, 63001,180, 63007,180, 63013,& + 180, 63023,180, 63029,180, 63059,180, 63061,180, 63083,& + 180, 63089,180, 63091,180, 63103,180, 63119,180, 63131,& + 180, 63163,180, 63227,180, 63233,180, 63239,180, 63259,& + 180, 63271,180, 63311,180, 63337,180, 63341,180, 63353,& + 180, 63367,180, 63373,180, 63397,180, 63409,180, 63413,& + 180, 63421,180, 63427,180, 63437,180, 63443,180, 63449,& + 180, 63481,180, 63499,180, 63509,180, 63517,180, 63541,& + 180, 63551,180, 63559,180, 63569,180, 63601,180, 63607,& + 180, 63617,180, 63623,180, 63629,180, 63637,180, 63653,& + 180, 63671,180, 63691,180, 63727,180, 63743,180, 63751,& + 180, 63763,180, 63787,180, 63821,180, 63827,180, 63847,& + 180, 63899,180, 63917,180, 63931,180, 63989,180, 63997,& + 180, 64003,180, 64007,180, 64009,180, 64013,180, 64037,& + 180, 64067,180, 64087,180, 64093,180, 64133,180, 64139,& + 180, 64147,180, 64157,180, 64163,180, 64169,180, 64181,& + 180, 64189,180, 64207,180, 64211,180, 64217,180, 64219,& + 180, 64223,180, 64247,180, 64261,180, 64273,180, 64297,& + 180, 64307,180, 64309,180, 64331,180, 64357,180, 64379,& + 180, 64387,180, 64409,180, 64417,180, 64483,180, 64489,& + 180, 64493,180, 64513,180, 64531,180, 64553,180, 64591,& + 180, 64601,180, 64609,180, 64613,180, 64619,180, 64627,& + 180, 64651,180, 64661,180, 64679,180, 64687,180, 64711,& + 180, 64717,180, 64727,180, 64739,180, 64741,180, 64751,& + 180, 64757,180, 64793,180, 64813,180, 64819,180, 64823,& + 180, 64847,180, 64871,180, 64877,180, 64883,180, 64891,& + 180, 64921,180, 64927,180, 64931,180, 64933,180, 64949,& + 180, 64961,180, 64987,180, 65047,180, 65059,180, 65063,& + 180, 65077,180, 65089,180, 65093,180, 65099,180, 65101,& + 180, 65119,180, 65131,180, 65137,180, 65147,180, 65159,& + 180, 65171,180, 65179,180, 65191,180, 65203,180, 65207,& + 180, 65213,180, 65221,180, 65231,180, 65233,180, 65269,& + 180, 65311,180, 65323,180, 65339,180, 65347,180, 65369,& + 180, 65393,180, 65399,180, 65407,180, 65431,180, 65437,& + 180, 65441,180, 65443,180, 65473,180, 65479,180, 65507,& + 180, 65527,180, 65533,181, 13,181, 15,181, 33,& + 181, 61,181, 67,181, 141,181, 151,181, 183,& + 181, 187,181, 201,181, 207,181, 213,181, 217,& + 181, 223,181, 225,181, 243,181, 253,181, 255,& + 181, 277,181, 291,181, 297,181, 301,181, 327,& + 181, 337,181, 357,181, 375,181, 423,181, 453,& + 181, 477,181, 511,181, 531,181, 547,181, 553,& + 181, 561,181, 565,181, 595,181, 607,181, 645/ + DATA ((n(i,j),i=3,4),j=980,nmax)/ & + 181, 657,181, 663,181, 685,181, 687,181, 697,& + 181, 745,181, 775,181, 787,181, 823,181, 825,& + 181, 841,181, 853,181, 865,181, 895,181, 903,& + 181, 943,181, 963,181, 973,181, 981,181, 1005,& + 181, 1015,181, 1021,181, 1023,181, 1041,181, 1051,& + 181, 1057,181, 1083,181, 1093,181, 1105,181, 1107,& + 181, 1117,181, 1135,181, 1137,181, 1155,181, 1167,& + 181, 1191,181, 1197,181, 1221,181, 1233,181, 1237,& + 181, 1243,181, 1263/ +! end +#endif +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! prng_32.f +!----------------------------------------------------------------------------- +#if defined(AIX) || defined(AMD64) + real(kind=8) function prng_next(me) +! implicit none + integer :: me +! +! Calling sequence: +! = prng_next ( ) +! = vprng ( , , ) +! +! This code is based on a sequential algorithm provided by Mal Kalos. +! This version uses a single 64-bit word to store the initial seeds +! and additive constants. +! A 64-bit floating point number is returned. +! +! The array "iparam" is full-word aligned, being padded by zeros to +! let each generator be on a subpage boundary. +! That is, rows 1 and 2 in a given column of the array are for real, +! rows 3-16 are bogus. +! +! July 12, 1993: double the number of sequences. We should have been +! using two packets per seed, rather than four +! October 31, 1993: merge the two arrays of seeds and constants, +! and switch to 64-bit arithmetic. +! June 1994: port to RS6K. Internal state is kept as 2 64-bit integers +! The ishft function is defined only on 32-bit integers, so we will +! shift numbers by dividing by 2**11 and then adding on 2**53-1. +! +! November 1994: ishift now works on 64-bit numbers (though it gives a +! warning). Thus we go back to using it. John Zollweg also added the +! vprng() routine to return vectors of real*8 random numbers. +! + real(kind=8),parameter :: recip53 = 2.0D0**(-53) + integer(kind=8),parameter :: two = 2**11 + integer(kind=8) :: m,ishift +! parameter ( m = 34522712143931 ) ! 11**13 +! parameter ( ishift = 9007199254740991 ) ! 2**53-1 + +!EL integer nmax +!EL integer*8 iparam +!EL parameter(nmax=1021) +!EL common/ksrprng/iparam(2,0:nmax) + + integer(kind=8) :: next + +!rc g77 doesn't support integer*8 constants + m = dint(34522712143931.0d0) + ishift = dint(9007199254740991.0d0) + if(me.gt.nmax) me=mod(me,nmax) + +! RS6K porting note: ishift now takes 64-bit integers , with a warning + if ( 0.le.me .and. me.le.nmax ) then + next = iparam(1,me)*m + iparam(2,me) + iparam(1,me) = next + prng_next = recip53 * ishft( next, -11 ) + else + prng_next=-1.0D0 + endif + + end function prng_next +!----------------------------------------------------------------------------- +! +! vprng(me, rn, num) Get a vector of random numbers +! + subroutine vprng(me,rn,num) + + real(kind=8),parameter :: recip53 = 2.0D0**(-53) + real(kind=8),dimension(1) :: rn + + integer(kind=8) :: m +!EL ,iparam +! parameter ( m = 34522712143931 ) ! 11**13 +!EL integer nmax, + integer :: num, me,i +!EL parameter(nmax=1021) +!EL common/ksrprng/iparam(2,0:nmax) + + integer(kind=8) :: next + +!rc g77 doesn't support integer*8 constants + m = dint(34522712143931.0d0) + + if ( 0.le.me .and. me.le.nmax ) then + do 1 i=1,num + next = iparam(1,me)*m + iparam(2,me) + iparam(1,me) = next + rn(i) = recip53 * ishft( next, -11 ) + 1 continue + else + rn(1)=-1.0D0 + endif + return + end subroutine vprng +!----------------------------------------------------------------------------- +! +! prng_chkpnt Get the current state of a generator +! +! Calling sequence: +! logical prng_chkpnt, status +! status = prng_chkpnt (me, iseed) where +! +! me is the particular generator whose state is being gotten +! seed is an 4-element integer array where the "l"-values will be saved +! + logical function prng_chkpnt(me,iseed) +! implicit none + integer :: me + integer(kind=8) :: iseed + +!EL integer nmax +!EL integer*8 iparam +!EL parameter(nmax=1021) +!EL common/ksrprng/iparam(2,0:nmax) + + if (me .lt. 0 .or. me .gt. nmax) then + prng_chkpnt=.false. + else + prng_chkpnt=.true. + iseed=iparam(1,me) + endif + end function prng_chkpnt +!----------------------------------------------------------------------------- +! +! prng_restart Restart generator from a saved state +! +! Calling sequence: +! logical prng_restart, status +! status = prng_restart (me, iseed) where +! +! me is the particular generator being restarted +! iseed is a 8-byte integer containing the "l"-values +! + logical function prng_restart(me,iseed) +! implicit none + integer :: me + integer(kind=8) :: iseed + +!EL integer nmax +!EL integer*8 iparam +!EL parameter(nmax=1021) +!EL common/ksrprng/iparam(2,0:nmax) + + if(me.gt.nmax) me=mod(me,nmax) + if (me .lt. 0 .or. me .gt. nmax) then + prng_restart=.false. + return + else + prng_restart=.true. + iparam(1,me)=iseed + endif + end function prng_restart +!----------------------------------------------------------------------------- +#else + real(kind=4) function prng_next(me) +!rc logical prng_restart, prng_chkpnt +! +! Calling sequence: +! = prng_next ( ) +! +! This code is based on a sequential algorithm provided by Mal Kalos. +! This version uses 4 16-bit packets, and uses a block data common +! area for the initial seeds and constants. A 64-bit floating point +! number is returned. +! +! The arrays "l" and "n" are full-word aligned, being padded by zeros +! That is, rows 1-4 in a given column are for real, rows 5-16 are bogus +! +! July 12, 1993: double the number of sequences. We should have been +! using two packets per seed, rather than four +! + real(kind=4),parameter :: tpm12 = 1.d0/65536.d0 + integer,dimension(4) :: iseed + integer :: me +!EL parameter(nmax=1021) +! external prngblk +!el integer,dimension(16,0:nmax) :: l,n +!EL common/ksrprng/l(16,0:nmax),n(16,0:nmax) +!*ksr*subpage /ksrprng/ + integer :: m1,m2,m3,m4,l1,l2,l3,l4,i1,i2,i3,i4 + data m1,m2,m3,m4 / 0, 8037, 61950, 30779/ + if (me .lt. 0 .or. me .gt. nmax) then + prng_next=-1.0 + return + endif + l1=l(1,me) + l2=l(2,me) + l3=l(3,me) + l4=l(4,me) + i1=l1*m4+l2*m3+l3*m2+l4*m1 + n(1,me) + i2=l2*m4+l3*m3+l4*m2 + n(2,me) + i3=l3*m4+l4*m3 + n(3,me) + i4=l4*m4 + n(4,me) + l4=and(i4,65535) + i3=i3+ishft(i4,-16) + l3=and(i3,65535) + i2=i2+ishft(i3,-16) + l2=and(i2,65535) + l1=and(i1+ishft(i2,-16),65535) + prng_next=tpm12*(l1+tpm12*(l2+tpm12*(l3+tpm12*l4))) + l(1,me)=l1 + l(2,me)=l2 + l(3,me)=l3 + l(4,me)=l4 + return + end function prng_next +!----------------------------------------------------------------------------- +! +! prng_chkpnt Get the current state of a generator +! +! Calling sequence: +! logical prng_chkpnt, status +! status = prng_chkpnt (me, iseed) where +! +! me is the particular generator whose state is being gotten +! seed is an 4-element integer array where the "l"-values will be saved +! +!rc entry prng_chkpnt (me, iseed) + logical function prng_chkpnt(me,iseed) + integer,dimension(4) :: iseed + integer :: me +!el parameter(nmax=1021) +!el common/ksrprng/l(16,0:nmax),n(16,0:nmax) + if (me .lt. 0 .or. me .gt. nmax) then + prng_chkpnt=.false. + else + prng_chkpnt=.true. + iseed(1)=l(1,me) + iseed(2)=l(2,me) + iseed(3)=l(3,me) + iseed(4)=l(4,me) + endif + return + end function prng_chkpnt +!----------------------------------------------------------------------------- +! prng_restart Restart generator from a saved state +! +! Calling sequence: +! logical prng_restart, status +! status = prng_restart (me, iseed) where +! +! me is the particular generator being restarted +! seed is an 4-element integer array containing the "l"-values +! +!rc entry prng_restart (me, iseed) + logical function prng_restart(me,iseed) + + integer,dimension(4) :: iseed + integer :: me +!el parameter(nmax=1021) +!el common/ksrprng/l(16,0:nmax),n(16,0:nmax) + if (me .lt. 0 .or. me .gt. nmax) then + prng_restart=.false. + return + else + prng_restart=.true. + l(1,me)=iseed(1) + l(2,me)=iseed(2) + l(3,me)=iseed(3) + l(4,me)=iseed(4) + endif + return + end function prng_restart +#endif +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module prng diff --git a/source/unres/prng_32.f90 b/source/unres/prng_32.f90 deleted file mode 100644 index a991715..0000000 --- a/source/unres/prng_32.f90 +++ /dev/null @@ -1,1102 +0,0 @@ - module prng - implicit none -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! -#if defined(AIX) || defined(AMD64) -! block data prngblk - integer,parameter :: nmax=1021 - integer(kind=8),dimension(2,0:nmax) :: iparam -! common/ksrprng/iparam(2,0:nmax) - integer,private :: i,j - data (iparam(1,i),iparam(2,i),i= 0, 29) / & - 11848219, 11848219, 11848237, 11848237, 11848241, 11848241,& - 11848247, 11848247, 11848253, 11848253, 11848271, 11848271,& - 11848297, 11848297, 11848313, 11848313, 11848339, 11848339,& - 11848351, 11848351, 11848357, 11848357, 11848363, 11848363,& - 11848367, 11848367, 11848373, 11848373, 11848379, 11848379,& - 11848393, 11848393, 11848433, 11848433, 11848451, 11848451,& - 11848469, 11848469, 11848477, 11848477, 11848489, 11848489,& - 11848493, 11848493, 11848513, 11848513, 11848523, 11848523,& - 11848531, 11848531, 11848537, 11848537, 11848553, 11848553,& - 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / - data (iparam(1,i),iparam(2,i),i= 30, 59) / & - 11848619, 11848619, 11848637, 11848637, 11848663, 11848663,& - 11848673, 11848673, 11848679, 11848679, 11848691, 11848691,& - 11848699, 11848699, 11848709, 11848709, 11848717, 11848717,& - 11848721, 11848721, 11848729, 11848729, 11848741, 11848741,& - 11848751, 11848751, 11848757, 11848757, 11848787, 11848787,& - 11848801, 11848801, 11848829, 11848829, 11848853, 11848853,& - 11848861, 11848861, 11848867, 11848867, 11848873, 11848873,& - 11848891, 11848891, 11848909, 11848909, 11848919, 11848919,& - 11848931, 11848931, 11848937, 11848937, 11848961, 11848961,& - 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / - data (iparam(1,i),iparam(2,i),i= 60, 89) / & - 11849053, 11849053, 11849059, 11849059, 11849069, 11849069,& - 11849077, 11849077, 11849087, 11849087, 11849093, 11849093,& - 11849107, 11849107, 11849111, 11849111, 11849129, 11849129,& - 11849137, 11849137, 11849177, 11849177, 11849183, 11849183,& - 11849203, 11849203, 11849231, 11849231, 11849237, 11849237,& - 11849239, 11849239, 11849249, 11849249, 11849251, 11849251,& - 11849269, 11849269, 11849273, 11849273, 11849291, 11849291,& - 11849297, 11849297, 11849309, 11849309, 11849339, 11849339,& - 11849359, 11849359, 11849363, 11849363, 11849399, 11849399,& - 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / - data (iparam(1,i),iparam(2,i),i= 90, 119) / & - 11849437, 11849437, 11849443, 11849443, 11849473, 11849473,& - 11849491, 11849491, 11849503, 11849503, 11849507, 11849507,& - 11849557, 11849557, 11849567, 11849567, 11849569, 11849569,& - 11849573, 11849573, 11849587, 11849587, 11849599, 11849599,& - 11849633, 11849633, 11849641, 11849641, 11849653, 11849653,& - 11849659, 11849659, 11849671, 11849671, 11849683, 11849683,& - 11849689, 11849689, 11849693, 11849693, 11849699, 11849699,& - 11849701, 11849701, 11849707, 11849707, 11849713, 11849713,& - 11849723, 11849723, 11849741, 11849741, 11849743, 11849743,& - 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / - data (iparam(1,i),iparam(2,i),i= 120, 149) / & - 11849791, 11849791, 11849801, 11849801, 11849809, 11849809,& - 11849813, 11849813, 11849869, 11849869, 11849881, 11849881,& - 11849891, 11849891, 11849909, 11849909, 11849923, 11849923,& - 11849933, 11849933, 11849947, 11849947, 11849987, 11849987,& - 11850001, 11850001, 11850011, 11850011, 11850019, 11850019,& - 11850023, 11850023, 11850031, 11850031, 11850049, 11850049,& - 11850061, 11850061, 11850073, 11850073, 11850077, 11850077,& - 11850103, 11850103, 11850109, 11850109, 11850121, 11850121,& - 11850127, 11850127, 11850133, 11850133, 11850149, 11850149,& - 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / - data (iparam(1,i),iparam(2,i),i= 150, 179) / & - 11850233, 11850233, 11850247, 11850247, 11850259, 11850259,& - 11850269, 11850269, 11850283, 11850283, 11850301, 11850301,& - 11850341, 11850341, 11850347, 11850347, 11850367, 11850367,& - 11850373, 11850373, 11850379, 11850379, 11850389, 11850389,& - 11850407, 11850407, 11850427, 11850427, 11850437, 11850437,& - 11850469, 11850469, 11850481, 11850481, 11850511, 11850511,& - 11850529, 11850529, 11850541, 11850541, 11850557, 11850557,& - 11850607, 11850607, 11850611, 11850611, 11850667, 11850667,& - 11850677, 11850677, 11850679, 11850679, 11850701, 11850701,& - 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / - data (iparam(1,i),iparam(2,i),i= 180, 209) / & - 11850791, 11850791, 11850803, 11850803, 11850829, 11850829,& - 11850833, 11850833, 11850859, 11850859, 11850877, 11850877,& - 11850899, 11850899, 11850907, 11850907, 11850913, 11850913,& - 11850919, 11850919, 11850931, 11850931, 11850941, 11850941,& - 11850947, 11850947, 11850953, 11850953, 11850961, 11850961,& - 11850983, 11850983, 11850991, 11850991, 11850997, 11850997,& - 11851031, 11851031, 11851033, 11851033, 11851051, 11851051,& - 11851061, 11851061, 11851067, 11851067, 11851093, 11851093,& - 11851109, 11851109, 11851123, 11851123, 11851127, 11851127,& - 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / - data (iparam(1,i),iparam(2,i),i= 210, 239) / & - 11851181, 11851181, 11851201, 11851201, 11851219, 11851219,& - 11851291, 11851291, 11851303, 11851303, 11851309, 11851309,& - 11851313, 11851313, 11851319, 11851319, 11851349, 11851349,& - 11851351, 11851351, 11851361, 11851361, 11851373, 11851373,& - 11851403, 11851403, 11851409, 11851409, 11851423, 11851423,& - 11851447, 11851447, 11851451, 11851451, 11851481, 11851481,& - 11851493, 11851493, 11851519, 11851519, 11851523, 11851523,& - 11851529, 11851529, 11851547, 11851547, 11851549, 11851549,& - 11851559, 11851559, 11851577, 11851577, 11851589, 11851589,& - 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / - data (iparam(1,i),iparam(2,i),i= 240, 269) / & - 11851607, 11851607, 11851613, 11851613, 11851621, 11851621,& - 11851627, 11851627, 11851639, 11851639, 11851673, 11851673,& - 11851681, 11851681, 11851727, 11851727, 11851753, 11851753,& - 11851759, 11851759, 11851787, 11851787, 11851793, 11851793,& - 11851799, 11851799, 11851813, 11851813, 11851841, 11851841,& - 11851859, 11851859, 11851867, 11851867, 11851891, 11851891,& - 11851909, 11851909, 11851919, 11851919, 11851927, 11851927,& - 11851933, 11851933, 11851949, 11851949, 11851967, 11851967,& - 11851997, 11851997, 11852017, 11852017, 11852051, 11852051,& - 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / - data (iparam(1,i),iparam(2,i),i= 270, 299) / & - 11852089, 11852089, 11852129, 11852129, 11852147, 11852147,& - 11852149, 11852149, 11852161, 11852161, 11852171, 11852171,& - 11852177, 11852177, 11852209, 11852209, 11852221, 11852221,& - 11852237, 11852237, 11852251, 11852251, 11852263, 11852263,& - 11852273, 11852273, 11852279, 11852279, 11852287, 11852287,& - 11852293, 11852293, 11852297, 11852297, 11852303, 11852303,& - 11852311, 11852311, 11852327, 11852327, 11852339, 11852339,& - 11852341, 11852341, 11852359, 11852359, 11852369, 11852369,& - 11852437, 11852437, 11852453, 11852453, 11852459, 11852459,& - 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / - data (iparam(1,i),iparam(2,i),i= 300, 329) / & - 11852537, 11852537, 11852539, 11852539, 11852557, 11852557,& - 11852573, 11852573, 11852579, 11852579, 11852591, 11852591,& - 11852609, 11852609, 11852611, 11852611, 11852623, 11852623,& - 11852641, 11852641, 11852647, 11852647, 11852657, 11852657,& - 11852663, 11852663, 11852717, 11852717, 11852719, 11852719,& - 11852741, 11852741, 11852759, 11852759, 11852767, 11852767,& - 11852773, 11852773, 11852803, 11852803, 11852807, 11852807,& - 11852809, 11852809, 11852831, 11852831, 11852833, 11852833,& - 11852837, 11852837, 11852857, 11852857, 11852873, 11852873,& - 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / - data (iparam(1,i),iparam(2,i),i= 330, 359) / & - 11852921, 11852921, 11852957, 11852957, 11852959, 11852959,& - 11852969, 11852969, 11852983, 11852983, 11852989, 11852989,& - 11853001, 11853001, 11853013, 11853013, 11853019, 11853019,& - 11853031, 11853031, 11853089, 11853089, 11853133, 11853133,& - 11853157, 11853157, 11853161, 11853161, 11853181, 11853181,& - 11853203, 11853203, 11853217, 11853217, 11853221, 11853221,& - 11853227, 11853227, 11853241, 11853241, 11853307, 11853307,& - 11853319, 11853319, 11853323, 11853323, 11853329, 11853329,& - 11853367, 11853367, 11853383, 11853383, 11853419, 11853419,& - 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / - data (iparam(1,i),iparam(2,i),i= 360, 389) / & - 11853451, 11853451, 11853463, 11853463, 11853529, 11853529,& - 11853557, 11853557, 11853571, 11853571, 11853601, 11853601,& - 11853613, 11853613, 11853617, 11853617, 11853629, 11853629,& - 11853649, 11853649, 11853659, 11853659, 11853679, 11853679,& - 11853689, 11853689, 11853719, 11853719, 11853731, 11853731,& - 11853757, 11853757, 11853761, 11853761, 11853773, 11853773,& - 11853791, 11853791, 11853817, 11853817, 11853839, 11853839,& - 11853847, 11853847, 11853857, 11853857, 11853869, 11853869,& - 11853883, 11853883, 11853887, 11853887, 11853889, 11853889,& - 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / - data (iparam(1,i),iparam(2,i),i= 390, 419) / & - 11853931, 11853931, 11853943, 11853943, 11853979, 11853979,& - 11853991, 11853991, 11854001, 11854001, 11854009, 11854009,& - 11854019, 11854019, 11854057, 11854057, 11854061, 11854061,& - 11854147, 11854147, 11854159, 11854159, 11854163, 11854163,& - 11854169, 11854169, 11854211, 11854211, 11854247, 11854247,& - 11854261, 11854261, 11854267, 11854267, 11854279, 11854279,& - 11854303, 11854303, 11854327, 11854327, 11854331, 11854331,& - 11854333, 11854333, 11854363, 11854363, 11854379, 11854379,& - 11854399, 11854399, 11854411, 11854411, 11854429, 11854429,& - 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / - data (iparam(1,i),iparam(2,i),i= 420, 449) / & - 11854463, 11854463, 11854477, 11854477, 11854489, 11854489,& - 11854517, 11854517, 11854519, 11854519, 11854523, 11854523,& - 11854529, 11854529, 11854567, 11854567, 11854571, 11854571,& - 11854573, 11854573, 11854603, 11854603, 11854607, 11854607,& - 11854681, 11854681, 11854691, 11854691, 11854709, 11854709,& - 11854723, 11854723, 11854757, 11854757, 11854783, 11854783,& - 11854793, 11854793, 11854813, 11854813, 11854847, 11854847,& - 11854853, 11854853, 11854873, 11854873, 11854877, 11854877,& - 11854883, 11854883, 11854891, 11854891, 11854897, 11854897,& - 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / - data (iparam(1,i),iparam(2,i),i= 450, 479) / & - 11854961, 11854961, 11854963, 11854963, 11854979, 11854979,& - 11855003, 11855003, 11855017, 11855017, 11855023, 11855023,& - 11855029, 11855029, 11855033, 11855033, 11855111, 11855111,& - 11855141, 11855141, 11855147, 11855147, 11855149, 11855149,& - 11855159, 11855159, 11855177, 11855177, 11855203, 11855203,& - 11855213, 11855213, 11855219, 11855219, 11855231, 11855231,& - 11855267, 11855267, 11855269, 11855269, 11855303, 11855303,& - 11855309, 11855309, 11855321, 11855321, 11855329, 11855329,& - 11855339, 11855339, 11855351, 11855351, 11855353, 11855353,& - 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / - data (iparam(1,i),iparam(2,i),i= 480, 509) / & - 11855383, 11855383, 11855387, 11855387, 11855399, 11855399,& - 11855407, 11855407, 11855413, 11855413, 11855489, 11855489,& - 11855491, 11855491, 11855507, 11855507, 11855521, 11855521,& - 11855531, 11855531, 11855549, 11855549, 11855551, 11855551,& - 11855567, 11855567, 11855581, 11855581, 11855587, 11855587,& - 11855593, 11855593, 11855633, 11855633, 11855653, 11855653,& - 11855663, 11855663, 11855687, 11855687, 11855689, 11855689,& - 11855699, 11855699, 11855713, 11855713, 11855731, 11855731,& - 11855737, 11855737, 11855743, 11855743, 11855747, 11855747,& - 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / - data (iparam(1,i),iparam(2,i),i= 510, 539) / & - 11855807, 11855807, 11855813, 11855813, 11855827, 11855827,& - 11855839, 11855839, 11855869, 11855869, 11855881, 11855881,& - 11855903, 11855903, 11855911, 11855911, 11855933, 11855933,& - 11855959, 11855959, 11855989, 11855989, 11855993, 11855993,& - 11855999, 11855999, 11856001, 11856001, 11856023, 11856023,& - 11856049, 11856049, 11856071, 11856071, 11856101, 11856101,& - 11856107, 11856107, 11856113, 11856113, 11856139, 11856139,& - 11856151, 11856151, 11856161, 11856161, 11856179, 11856179,& - 11856193, 11856193, 11856199, 11856199, 11856223, 11856223,& - 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / - data (iparam(1,i),iparam(2,i),i= 540, 569) / & - 11856281, 11856281, 11856287, 11856287, 11856307, 11856307,& - 11856311, 11856311, 11856329, 11856329, 11856343, 11856343,& - 11856359, 11856359, 11856371, 11856371, 11856373, 11856373,& - 11856409, 11856409, 11856419, 11856419, 11856461, 11856461,& - 11856469, 11856469, 11856473, 11856473, 11856479, 11856479,& - 11856511, 11856511, 11856517, 11856517, 11856541, 11856541,& - 11856547, 11856547, 11856553, 11856553, 11856583, 11856583,& - 11856629, 11856629, 11856641, 11856641, 11856653, 11856653,& - 11856659, 11856659, 11856673, 11856673, 11856697, 11856697,& - 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / - data (iparam(1,i),iparam(2,i),i= 570, 599) / & - 11856763, 11856763, 11856809, 11856809, 11856811, 11856811,& - 11856821, 11856821, 11856841, 11856841, 11856857, 11856857,& - 11856877, 11856877, 11856883, 11856883, 11856899, 11856899,& - 11856919, 11856919, 11856947, 11856947, 11856953, 11856953,& - 11856979, 11856979, 11857003, 11857003, 11857033, 11857033,& - 11857037, 11857037, 11857039, 11857039, 11857049, 11857049,& - 11857061, 11857061, 11857067, 11857067, 11857073, 11857073,& - 11857081, 11857081, 11857091, 11857091, 11857093, 11857093,& - 11857099, 11857099, 11857123, 11857123, 11857127, 11857127,& - 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / - data (iparam(1,i),iparam(2,i),i= 600, 629) / & - 11857217, 11857217, 11857229, 11857229, 11857243, 11857243,& - 11857249, 11857249, 11857267, 11857267, 11857277, 11857277,& - 11857291, 11857291, 11857303, 11857303, 11857309, 11857309,& - 11857327, 11857327, 11857331, 11857331, 11857333, 11857333,& - 11857361, 11857361, 11857367, 11857367, 11857369, 11857369,& - 11857393, 11857393, 11857399, 11857399, 11857409, 11857409,& - 11857421, 11857421, 11857423, 11857423, 11857451, 11857451,& - 11857453, 11857453, 11857457, 11857457, 11857477, 11857477,& - 11857481, 11857481, 11857493, 11857493, 11857499, 11857499,& - 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / - data (iparam(1,i),iparam(2,i),i= 630, 659) / & - 11857543, 11857543, 11857561, 11857561, 11857589, 11857589,& - 11857591, 11857591, 11857613, 11857613, 11857621, 11857621,& - 11857661, 11857661, 11857667, 11857667, 11857693, 11857693,& - 11857697, 11857697, 11857709, 11857709, 11857711, 11857711,& - 11857751, 11857751, 11857753, 11857753, 11857759, 11857759,& - 11857763, 11857763, 11857777, 11857777, 11857787, 11857787,& - 11857793, 11857793, 11857801, 11857801, 11857817, 11857817,& - 11857819, 11857819, 11857831, 11857831, 11857837, 11857837,& - 11857873, 11857873, 11857877, 11857877, 11857883, 11857883,& - 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / - data (iparam(1,i),iparam(2,i),i= 660, 689) / & - 11857931, 11857931, 11857969, 11857969, 11857991, 11857991,& - 11857999, 11857999, 11858009, 11858009, 11858017, 11858017,& - 11858023, 11858023, 11858029, 11858029, 11858039, 11858039,& - 11858051, 11858051, 11858057, 11858057, 11858059, 11858059,& - 11858101, 11858101, 11858111, 11858111, 11858131, 11858131,& - 11858149, 11858149, 11858159, 11858159, 11858177, 11858177,& - 11858191, 11858191, 11858201, 11858201, 11858227, 11858227,& - 11858243, 11858243, 11858267, 11858267, 11858269, 11858269,& - 11858279, 11858279, 11858281, 11858281, 11858291, 11858291,& - 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / - data (iparam(1,i),iparam(2,i),i= 690, 719) / & - 11858377, 11858377, 11858381, 11858381, 11858387, 11858387,& - 11858423, 11858423, 11858443, 11858443, 11858447, 11858447,& - 11858479, 11858479, 11858533, 11858533, 11858543, 11858543,& - 11858551, 11858551, 11858557, 11858557, 11858569, 11858569,& - 11858573, 11858573, 11858579, 11858579, 11858597, 11858597,& - 11858599, 11858599, 11858629, 11858629, 11858657, 11858657,& - 11858659, 11858659, 11858683, 11858683, 11858701, 11858701,& - 11858719, 11858719, 11858723, 11858723, 11858729, 11858729,& - 11858747, 11858747, 11858779, 11858779, 11858783, 11858783,& - 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / - data (iparam(1,i),iparam(2,i),i= 720, 749) / & - 11858839, 11858839, 11858851, 11858851, 11858893, 11858893,& - 11858897, 11858897, 11858921, 11858921, 11858947, 11858947,& - 11858953, 11858953, 11858969, 11858969, 11858971, 11858971,& - 11858989, 11858989, 11859017, 11859017, 11859031, 11859031,& - 11859049, 11859049, 11859061, 11859061, 11859073, 11859073,& - 11859077, 11859077, 11859079, 11859079, 11859083, 11859083,& - 11859101, 11859101, 11859109, 11859109, 11859137, 11859137,& - 11859139, 11859139, 11859151, 11859151, 11859157, 11859157,& - 11859163, 11859163, 11859167, 11859167, 11859179, 11859179,& - 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / - data (iparam(1,i),iparam(2,i),i= 750, 779) / & - 11859241, 11859241, 11859247, 11859247, 11859269, 11859269,& - 11859293, 11859293, 11859307, 11859307, 11859311, 11859311,& - 11859349, 11859349, 11859359, 11859359, 11859371, 11859371,& - 11859377, 11859377, 11859383, 11859383, 11859427, 11859427,& - 11859433, 11859433, 11859451, 11859451, 11859457, 11859457,& - 11859461, 11859461, 11859473, 11859473, 11859481, 11859481,& - 11859487, 11859487, 11859493, 11859493, 11859503, 11859503,& - 11859509, 11859509, 11859539, 11859539, 11859541, 11859541,& - 11859563, 11859563, 11859569, 11859569, 11859571, 11859571,& - 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / - data (iparam(1,i),iparam(2,i),i= 780, 809) / & - 11859643, 11859643, 11859707, 11859707, 11859713, 11859713,& - 11859719, 11859719, 11859739, 11859739, 11859751, 11859751,& - 11859791, 11859791, 11859817, 11859817, 11859821, 11859821,& - 11859833, 11859833, 11859847, 11859847, 11859853, 11859853,& - 11859877, 11859877, 11859889, 11859889, 11859893, 11859893,& - 11859901, 11859901, 11859907, 11859907, 11859917, 11859917,& - 11859923, 11859923, 11859929, 11859929, 11859961, 11859961,& - 11859979, 11859979, 11859989, 11859989, 11859997, 11859997,& - 11860021, 11860021, 11860031, 11860031, 11860039, 11860039,& - 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / - data (iparam(1,i),iparam(2,i),i= 810, 839) / & - 11860097, 11860097, 11860103, 11860103, 11860109, 11860109,& - 11860117, 11860117, 11860133, 11860133, 11860151, 11860151,& - 11860171, 11860171, 11860207, 11860207, 11860223, 11860223,& - 11860231, 11860231, 11860243, 11860243, 11860267, 11860267,& - 11860301, 11860301, 11860307, 11860307, 11860327, 11860327,& - 11860379, 11860379, 11860397, 11860397, 11860411, 11860411,& - 11860469, 11860469, 11860477, 11860477, 11860483, 11860483,& - 11860487, 11860487, 11860489, 11860489, 11860493, 11860493,& - 11860517, 11860517, 11860547, 11860547, 11860567, 11860567,& - 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / - data (iparam(1,i),iparam(2,i),i= 840, 869) / & - 11860627, 11860627, 11860637, 11860637, 11860643, 11860643,& - 11860649, 11860649, 11860661, 11860661, 11860669, 11860669,& - 11860687, 11860687, 11860691, 11860691, 11860697, 11860697,& - 11860699, 11860699, 11860703, 11860703, 11860727, 11860727,& - 11860741, 11860741, 11860753, 11860753, 11860777, 11860777,& - 11860787, 11860787, 11860789, 11860789, 11860811, 11860811,& - 11860837, 11860837, 11860859, 11860859, 11860867, 11860867,& - 11860889, 11860889, 11860897, 11860897, 11860963, 11860963,& - 11860969, 11860969, 11860973, 11860973, 11860993, 11860993,& - 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / - data (iparam(1,i),iparam(2,i),i= 870, 899) / & - 11861081, 11861081, 11861089, 11861089, 11861093, 11861093,& - 11861099, 11861099, 11861107, 11861107, 11861131, 11861131,& - 11861141, 11861141, 11861159, 11861159, 11861167, 11861167,& - 11861191, 11861191, 11861197, 11861197, 11861207, 11861207,& - 11861219, 11861219, 11861221, 11861221, 11861231, 11861231,& - 11861237, 11861237, 11861273, 11861273, 11861293, 11861293,& - 11861299, 11861299, 11861303, 11861303, 11861327, 11861327,& - 11861351, 11861351, 11861357, 11861357, 11861363, 11861363,& - 11861371, 11861371, 11861401, 11861401, 11861407, 11861407,& - 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / - data (iparam(1,i),iparam(2,i),i= 900, 929) / & - 11861441, 11861441, 11861467, 11861467, 11861527, 11861527,& - 11861539, 11861539, 11861543, 11861543, 11861557, 11861557,& - 11861569, 11861569, 11861573, 11861573, 11861579, 11861579,& - 11861581, 11861581, 11861599, 11861599, 11861611, 11861611,& - 11861617, 11861617, 11861627, 11861627, 11861639, 11861639,& - 11861651, 11861651, 11861659, 11861659, 11861671, 11861671,& - 11861683, 11861683, 11861687, 11861687, 11861693, 11861693,& - 11861701, 11861701, 11861711, 11861711, 11861713, 11861713,& - 11861749, 11861749, 11861791, 11861791, 11861803, 11861803,& - 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / - data (iparam(1,i),iparam(2,i),i= 930, 959) / & - 11861873, 11861873, 11861879, 11861879, 11861887, 11861887,& - 11861911, 11861911, 11861917, 11861917, 11861921, 11861921,& - 11861923, 11861923, 11861953, 11861953, 11861959, 11861959,& - 11861987, 11861987, 11862007, 11862007, 11862013, 11862013,& - 11862029, 11862029, 11862031, 11862031, 11862049, 11862049,& - 11862077, 11862077, 11862083, 11862083, 11862157, 11862157,& - 11862167, 11862167, 11862199, 11862199, 11862203, 11862203,& - 11862217, 11862217, 11862223, 11862223, 11862229, 11862229,& - 11862233, 11862233, 11862239, 11862239, 11862241, 11862241,& - 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / - data (iparam(1,i),iparam(2,i),i= 960, 989) / & - 11862293, 11862293, 11862307, 11862307, 11862313, 11862313,& - 11862317, 11862317, 11862343, 11862343, 11862353, 11862353,& - 11862373, 11862373, 11862391, 11862391, 11862439, 11862439,& - 11862469, 11862469, 11862493, 11862493, 11862527, 11862527,& - 11862547, 11862547, 11862563, 11862563, 11862569, 11862569,& - 11862577, 11862577, 11862581, 11862581, 11862611, 11862611,& - 11862623, 11862623, 11862661, 11862661, 11862673, 11862673,& - 11862679, 11862679, 11862701, 11862701, 11862703, 11862703,& - 11862713, 11862713, 11862761, 11862761, 11862791, 11862791,& - 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / - data (iparam(1,i),iparam(2,i),i= 990,1019) / & - 11862857, 11862857, 11862869, 11862869, 11862881, 11862881,& - 11862911, 11862911, 11862919, 11862919, 11862959, 11862959,& - 11862979, 11862979, 11862989, 11862989, 11862997, 11862997,& - 11863021, 11863021, 11863031, 11863031, 11863037, 11863037,& - 11863039, 11863039, 11863057, 11863057, 11863067, 11863067,& - 11863073, 11863073, 11863099, 11863099, 11863109, 11863109,& - 11863121, 11863121, 11863123, 11863123, 11863133, 11863133,& - 11863151, 11863151, 11863153, 11863153, 11863171, 11863171,& - 11863183, 11863183, 11863207, 11863207, 11863213, 11863213,& - 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / - data (iparam(1,i),iparam(2,i),i=1020,1021) / & - 11863259, 11863259, 11863279, 11863279 / -! end -!----------------------------------------------------------------------------- -#else -! block data prngblk -! -! Sequence of prime numbers represented as pairs of 16-bit integers -! modulo 2**16, obtained from Mal Kalos August 28, 1992. Only 98 -! continuation cards are allowed by ksr Fortran, so several DATA -! statements are used to initialize 1022 generators. -! -! @cornell university, 1992 -! - integer,parameter :: nmax=1021,nmax1=2*nmax+2 - integer,dimension(16,0:nmax) :: l,n - integer,private :: i,j -! common/ksrprng/l(16,0:nmax),n(16,0:nmax) -!*ksr*subpage /ksrprng/ - -! High order quads in arrays "l" and "n" are initialized to zero : rows 1-2 -! Rows 5-16 remain uninitialized. They are just pads, never used. - DATA ((l(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ - DATA ((n(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ - -! The rest of array "l" and "n" are initialized to a 20-bit seed - DATA ((l(i,j),i=3,4),j=0,489)/ & - 180, 51739,180, 51757,180, 51761,180, 51767,180,51773,& - 180, 51791,180, 51817,180, 51833,180, 51859,180, 51871,& - 180, 51877,180, 51883,180, 51887,180, 51893,180, 51899,& - 180, 51913,180, 51953,180, 51971,180, 51989,180, 51997,& - 180, 52009,180, 52013,180, 52033,180, 52043,180, 52051,& - 180, 52057,180, 52073,180, 52109,180, 52111,180, 52121,& - 180, 52139,180, 52157,180, 52183,180, 52193,180, 52199,& - 180, 52211,180, 52219,180, 52229,180, 52237,180, 52241,& - 180, 52249,180, 52261,180, 52271,180, 52277,180, 52307,& - 180, 52321,180, 52349,180, 52373,180, 52381,180, 52387,& - 180, 52393,180, 52411,180, 52429,180, 52439,180, 52451,& - 180, 52457,180, 52481,180, 52501,180, 52541,180, 52559,& - 180, 52573,180, 52579,180, 52589,180, 52597,180, 52607,& - 180, 52613,180, 52627,180, 52631,180, 52649,180, 52657,& - 180, 52697,180, 52703,180, 52723,180, 52751,180, 52757,& - 180, 52759,180, 52769,180, 52771,180, 52789,180, 52793,& - 180, 52811,180, 52817,180, 52829,180, 52859,180, 52879,& - 180, 52883,180, 52919,180, 52921,180, 52933,180, 52937,& - 180, 52957,180, 52963,180, 52993,180, 53011,180, 53023,& - 180, 53027,180, 53077,180, 53087,180, 53089,180, 53093,& - 180, 53107,180, 53119,180, 53153,180, 53161,180, 53173,& - 180, 53179,180, 53191,180, 53203,180, 53209,180, 53213,& - 180, 53219,180, 53221,180, 53227,180, 53233,180, 53243,& - 180, 53261,180, 53263,180, 53279,180, 53287,180, 53291,& - 180, 53311,180, 53321,180, 53329,180, 53333,180, 53389,& - 180, 53401,180, 53411,180, 53429,180, 53443,180, 53453,& - 180, 53467,180, 53507,180, 53521,180, 53531,180, 53539,& - 180, 53543,180, 53551,180, 53569,180, 53581,180, 53593,& - 180, 53597,180, 53623,180, 53629,180, 53641,180, 53647,& - 180, 53653,180, 53669,180, 53681,180, 53689,180, 53711,& - 180, 53753,180, 53767,180, 53779,180, 53789,180, 53803,& - 180, 53821,180, 53861,180, 53867,180, 53887,180, 53893,& - 180, 53899,180, 53909,180, 53927,180, 53947,180, 53957,& - 180, 53989,180, 54001,180, 54031,180, 54049,180, 54061,& - 180, 54077,180, 54127,180, 54131,180, 54187,180, 54197,& - 180, 54199,180, 54221,180, 54251,180, 54259,180, 54269,& - 180, 54311,180, 54323,180, 54349,180, 54353,180, 54379,& - 180, 54397,180, 54419,180, 54427,180, 54433,180, 54439,& - 180, 54451,180, 54461,180, 54467,180, 54473,180, 54481,& - 180, 54503,180, 54511,180, 54517,180, 54551,180, 54553,& - 180, 54571,180, 54581,180, 54587,180, 54613,180, 54629,& - 180, 54643,180, 54647,180, 54659,180, 54677,180, 54683,& - 180, 54701,180, 54721,180, 54739,180, 54811,180, 54823,& - 180, 54829,180, 54833,180, 54839,180, 54869,180, 54871,& - 180, 54881,180, 54893,180, 54923,180, 54929,180, 54943,& - 180, 54967,180, 54971,180, 55001,180, 55013,180, 55039,& - 180, 55043,180, 55049,180, 55067,180, 55069,180, 55079,& - 180, 55097,180, 55109,180, 55111,180, 55117,180, 55123,& - 180, 55127,180, 55133,180, 55141,180, 55147,180, 55159,& - 180, 55193,180, 55201,180, 55247,180, 55273,180, 55279,& - 180, 55307,180, 55313,180, 55319,180, 55333,180, 55361,& - 180, 55379,180, 55387,180, 55411,180, 55429,180, 55439,& - 180, 55447,180, 55453,180, 55469,180, 55487,180, 55517,& - 180, 55537,180, 55571,180, 55573,180, 55579,180, 55603,& - 180, 55609,180, 55649,180, 55667,180, 55669,180, 55681,& - 180, 55691,180, 55697,180, 55729,180, 55741,180, 55757,& - 180, 55771,180, 55783,180, 55793,180, 55799,180, 55807,& - 180, 55813,180, 55817,180, 55823,180, 55831,180, 55847,& - 180, 55859,180, 55861,180, 55879,180, 55889,180, 55957,& - 180, 55973,180, 55979,180, 55993,180, 56033,180, 56051,& - 180, 56057,180, 56059,180, 56077,180, 56093,180, 56099,& - 180, 56111,180, 56129,180, 56131,180, 56143,180, 56161,& - 180, 56167,180, 56177,180, 56183,180, 56237,180, 56239,& - 180, 56261,180, 56279,180, 56287,180, 56293,180, 56323,& - 180, 56327,180, 56329,180, 56351,180, 56353,180, 56357,& - 180, 56377,180, 56393,180, 56399,180, 56411,180, 56437,& - 180, 56441,180, 56477,180, 56479,180, 56489,180, 56503,& - 180, 56509,180, 56521,180, 56533,180, 56539,180, 56551,& - 180, 56609,180, 56653,180, 56677,180, 56681,180, 56701,& - 180, 56723,180, 56737,180, 56741,180, 56747,180, 56761,& - 180, 56827,180, 56839,180, 56843,180, 56849,180, 56887,& - 180, 56903,180, 56939,180, 56941,180, 56947,180, 56969,& - 180, 56971,180, 56983,180, 57049,180, 57077,180, 57091,& - 180, 57121,180, 57133,180, 57137,180, 57149,180, 57169,& - 180, 57179,180, 57199,180, 57209,180, 57239,180, 57251,& - 180, 57277,180, 57281,180, 57293,180, 57311,180, 57337,& - 180, 57359,180, 57367,180, 57377,180, 57389,180, 57403,& - 180, 57407,180, 57409,180, 57413,180, 57419,180, 57431,& - 180, 57451,180, 57463,180, 57499,180, 57511,180, 57521,& - 180, 57529,180, 57539,180, 57577,180, 57581,180, 57667,& - 180, 57679,180, 57683,180, 57689,180, 57731,180, 57767,& - 180, 57781,180, 57787,180, 57799,180, 57823,180, 57847,& - 180, 57851,180, 57853,180, 57883,180, 57899,180, 57919,& - 180, 57931,180, 57949,180, 57953,180, 57959,180, 57961,& - 180, 57983,180, 57997,180, 58009,180, 58037,180, 58039,& - 180, 58043,180, 58049,180, 58087,180, 58091,180, 58093,& - 180, 58123,180, 58127,180, 58201,180, 58211,180, 58229,& - 180, 58243,180, 58277,180, 58303,180, 58313,180, 58333,& - 180, 58367,180, 58373,180, 58393,180, 58397,180, 58403,& - 180, 58411,180, 58417,180, 58421,180, 58439,180, 58457,& - 180, 58481,180, 58483,180, 58499,180, 58523,180, 58537,& - 180, 58543,180, 58549,180, 58553,180, 58631,180, 58661,& - 180, 58667,180, 58669,180, 58679,180, 58697,180, 58723,& - 180, 58733,180, 58739,180, 58751,180, 58787,180, 58789,& - 180, 58823,180, 58829,180, 58841,180, 58849,180, 58859,& - 180, 58871,180, 58873,180, 58877,180, 58879,180, 58901,& - 180, 58903,180, 58907,180, 58919,180, 58927,180, 58933,& - 180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ - DATA ((l(i,j),i=3,4),j=490,979)/ & - 180, 59069,180, 59071,180, 59087,180, 59101,180, 59107,& - 180, 59113,180, 59153,180, 59173,180, 59183,180, 59207,& - 180, 59209,180, 59219,180, 59233,180, 59251,180, 59257,& - 180, 59263,180, 59267,180, 59279,180, 59293,180, 59321,& - 180, 59327,180, 59333,180, 59347,180, 59359,180, 59389,& - 180, 59401,180, 59423,180, 59431,180, 59453,180, 59479,& - 180, 59509,180, 59513,180, 59519,180, 59521,180, 59543,& - 180, 59569,180, 59591,180, 59621,180, 59627,180, 59633,& - 180, 59659,180, 59671,180, 59681,180, 59699,180, 59713,& - 180, 59719,180, 59743,180, 59759,180, 59783,180, 59789,& - 180, 59801,180, 59807,180, 59827,180, 59831,180, 59849,& - 180, 59863,180, 59879,180, 59891,180, 59893,180, 59929,& - 180, 59939,180, 59981,180, 59989,180, 59993,180, 59999,& - 180, 60031,180, 60037,180, 60061,180, 60067,180, 60073,& - 180, 60103,180, 60149,180, 60161,180, 60173,180, 60179,& - 180, 60193,180, 60217,180, 60229,180, 60247,180, 60251,& - 180, 60283,180, 60329,180, 60331,180, 60341,180, 60361,& - 180, 60377,180, 60397,180, 60403,180, 60419,180, 60439,& - 180, 60467,180, 60473,180, 60499,180, 60523,180, 60553,& - 180, 60557,180, 60559,180, 60569,180, 60581,180, 60587,& - 180, 60593,180, 60601,180, 60611,180, 60613,180, 60619,& - 180, 60643,180, 60647,180, 60667,180, 60671,180, 60713,& - 180, 60737,180, 60749,180, 60763,180, 60769,180, 60787,& - 180, 60797,180, 60811,180, 60823,180, 60829,180, 60847,& - 180, 60851,180, 60853,180, 60881,180, 60887,180, 60889,& - 180, 60913,180, 60919,180, 60929,180, 60941,180, 60943,& - 180, 60971,180, 60973,180, 60977,180, 60997,180, 61001,& - 180, 61013,180, 61019,180, 61039,180, 61043,180, 61049,& - 180, 61063,180, 61081,180, 61109,180, 61111,180, 61133,& - 180, 61141,180, 61181,180, 61187,180, 61213,180, 61217,& - 180, 61229,180, 61231,180, 61271,180, 61273,180, 61279,& - 180, 61283,180, 61297,180, 61307,180, 61313,180, 61321,& - 180, 61337,180, 61339,180, 61351,180, 61357,180, 61393,& - 180, 61397,180, 61403,180, 61409,180, 61427,180, 61433,& - 180, 61451,180, 61489,180, 61511,180, 61519,180, 61529,& - 180, 61537,180, 61543,180, 61549,180, 61559,180, 61571,& - 180, 61577,180, 61579,180, 61621,180, 61631,180, 61651,& - 180, 61669,180, 61679,180, 61697,180, 61711,180, 61721,& - 180, 61747,180, 61763,180, 61787,180, 61789,180, 61799,& - 180, 61801,180, 61811,180, 61831,180, 61843,180, 61879,& - 180, 61897,180, 61901,180, 61907,180, 61943,180, 61963,& - 180, 61967,180, 61999,180, 62053,180, 62063,180, 62071,& - 180, 62077,180, 62089,180, 62093,180, 62099,180, 62117,& - 180, 62119,180, 62149,180, 62177,180, 62179,180, 62203,& - 180, 62221,180, 62239,180, 62243,180, 62249,180, 62267,& - 180, 62299,180, 62303,180, 62321,180, 62327,180, 62333,& - 180, 62359,180, 62371,180, 62413,180, 62417,180, 62441,& - 180, 62467,180, 62473,180, 62489,180, 62491,180, 62509,& - 180, 62537,180, 62551,180, 62569,180, 62581,180, 62593,& - 180, 62597,180, 62599,180, 62603,180, 62621,180, 62629,& - 180, 62657,180, 62659,180, 62671,180, 62677,180, 62683,& - 180, 62687,180, 62699,180, 62707,180, 62749,180, 62753,& - 180, 62761,180, 62767,180, 62789,180, 62813,180, 62827,& - 180, 62831,180, 62869,180, 62879,180, 62891,180, 62897,& - 180, 62903,180, 62947,180, 62953,180, 62971,180, 62977,& - 180, 62981,180, 62993,180, 63001,180, 63007,180, 63013,& - 180, 63023,180, 63029,180, 63059,180, 63061,180, 63083,& - 180, 63089,180, 63091,180, 63103,180, 63119,180, 63131,& - 180, 63163,180, 63227,180, 63233,180, 63239,180, 63259,& - 180, 63271,180, 63311,180, 63337,180, 63341,180, 63353,& - 180, 63367,180, 63373,180, 63397,180, 63409,180, 63413,& - 180, 63421,180, 63427,180, 63437,180, 63443,180, 63449,& - 180, 63481,180, 63499,180, 63509,180, 63517,180, 63541,& - 180, 63551,180, 63559,180, 63569,180, 63601,180, 63607,& - 180, 63617,180, 63623,180, 63629,180, 63637,180, 63653,& - 180, 63671,180, 63691,180, 63727,180, 63743,180, 63751,& - 180, 63763,180, 63787,180, 63821,180, 63827,180, 63847,& - 180, 63899,180, 63917,180, 63931,180, 63989,180, 63997,& - 180, 64003,180, 64007,180, 64009,180, 64013,180, 64037,& - 180, 64067,180, 64087,180, 64093,180, 64133,180, 64139,& - 180, 64147,180, 64157,180, 64163,180, 64169,180, 64181,& - 180, 64189,180, 64207,180, 64211,180, 64217,180, 64219,& - 180, 64223,180, 64247,180, 64261,180, 64273,180, 64297,& - 180, 64307,180, 64309,180, 64331,180, 64357,180, 64379,& - 180, 64387,180, 64409,180, 64417,180, 64483,180, 64489,& - 180, 64493,180, 64513,180, 64531,180, 64553,180, 64591,& - 180, 64601,180, 64609,180, 64613,180, 64619,180, 64627,& - 180, 64651,180, 64661,180, 64679,180, 64687,180, 64711,& - 180, 64717,180, 64727,180, 64739,180, 64741,180, 64751,& - 180, 64757,180, 64793,180, 64813,180, 64819,180, 64823,& - 180, 64847,180, 64871,180, 64877,180, 64883,180, 64891,& - 180, 64921,180, 64927,180, 64931,180, 64933,180, 64949,& - 180, 64961,180, 64987,180, 65047,180, 65059,180, 65063,& - 180, 65077,180, 65089,180, 65093,180, 65099,180, 65101,& - 180, 65119,180, 65131,180, 65137,180, 65147,180, 65159,& - 180, 65171,180, 65179,180, 65191,180, 65203,180, 65207,& - 180, 65213,180, 65221,180, 65231,180, 65233,180, 65269,& - 180, 65311,180, 65323,180, 65339,180, 65347,180, 65369,& - 180, 65393,180, 65399,180, 65407,180, 65431,180, 65437,& - 180, 65441,180, 65443,180, 65473,180, 65479,180, 65507,& - 180, 65527,180, 65533,181, 13,181, 15,181, 33,& - 181, 61,181, 67,181, 141,181, 151,181, 183,& - 181, 187,181, 201,181, 207,181, 213,181, 217,& - 181, 223,181, 225,181, 243,181, 253,181, 255,& - 181, 277,181, 291,181, 297,181, 301,181, 327,& - 181, 337,181, 357,181, 375,181, 423,181, 453,& - 181, 477,181, 511,181, 531,181, 547,181, 553,& - 181, 561,181, 565,181, 595,181, 607,181, 645/ - DATA ((l(i,j),i=3,4),j=980,nmax)/ & - 181, 657,181, 663,181, 685,181, 687,181, 697,& - 181, 745,181, 775,181, 787,181, 823,181, 825,& - 181, 841,181, 853,181, 865,181, 895,181, 903,& - 181, 943,181, 963,181, 973,181, 981,181, 1005,& - 181,1015,181,1021,181,1023,181,1041,181,1051,& - 181, 1057,181, 1083,181, 1093,181, 1105,181, 1107,& - 181, 1117,181, 1135,181, 1137,181, 1155,181, 1167,& - 181, 1191,181, 1197,181, 1221,181, 1233,181, 1237,& - 181, 1243,181, 1263/ - DATA ((n(i,j),i=3,4),j=0,489)/ & - 180, 51739,180, 51757,180, 51761,180, 51767,180, 51773,& - 180, 51791,180, 51817,180, 51833,180, 51859,180, 51871,& - 180, 51877,180, 51883,180, 51887,180, 51893,180, 51899,& - 180, 51913,180, 51953,180, 51971,180, 51989,180, 51997,& - 180, 52009,180, 52013,180, 52033,180, 52043,180, 52051,& - 180, 52057,180, 52073,180, 52109,180, 52111,180, 52121,& - 180, 52139,180, 52157,180, 52183,180, 52193,180, 52199,& - 180, 52211,180, 52219,180, 52229,180, 52237,180, 52241,& - 180, 52249,180, 52261,180, 52271,180, 52277,180, 52307,& - 180, 52321,180, 52349,180, 52373,180, 52381,180, 52387,& - 180, 52393,180, 52411,180, 52429,180, 52439,180, 52451,& - 180, 52457,180, 52481,180, 52501,180, 52541,180, 52559,& - 180, 52573,180, 52579,180, 52589,180, 52597,180, 52607,& - 180, 52613,180, 52627,180, 52631,180, 52649,180, 52657,& - 180, 52697,180, 52703,180, 52723,180, 52751,180, 52757,& - 180, 52759,180, 52769,180, 52771,180, 52789,180, 52793,& - 180, 52811,180, 52817,180, 52829,180, 52859,180, 52879,& - 180, 52883,180, 52919,180, 52921,180, 52933,180, 52937,& - 180, 52957,180, 52963,180, 52993,180, 53011,180, 53023,& - 180, 53027,180, 53077,180, 53087,180, 53089,180, 53093,& - 180, 53107,180, 53119,180, 53153,180, 53161,180, 53173,& - 180, 53179,180, 53191,180, 53203,180, 53209,180, 53213,& - 180, 53219,180, 53221,180, 53227,180, 53233,180, 53243,& - 180, 53261,180, 53263,180, 53279,180, 53287,180, 53291,& - 180, 53311,180, 53321,180, 53329,180, 53333,180, 53389,& - 180, 53401,180, 53411,180, 53429,180, 53443,180, 53453,& - 180, 53467,180, 53507,180, 53521,180, 53531,180, 53539,& - 180, 53543,180, 53551,180, 53569,180, 53581,180, 53593,& - 180, 53597,180, 53623,180, 53629,180, 53641,180, 53647,& - 180, 53653,180, 53669,180, 53681,180, 53689,180, 53711,& - 180, 53753,180, 53767,180, 53779,180, 53789,180, 53803,& - 180, 53821,180, 53861,180, 53867,180, 53887,180, 53893,& - 180, 53899,180, 53909,180, 53927,180, 53947,180, 53957,& - 180, 53989,180, 54001,180, 54031,180, 54049,180, 54061,& - 180, 54077,180, 54127,180, 54131,180, 54187,180, 54197,& - 180, 54199,180, 54221,180, 54251,180, 54259,180, 54269,& - 180, 54311,180, 54323,180, 54349,180, 54353,180, 54379,& - 180, 54397,180, 54419,180, 54427,180, 54433,180, 54439,& - 180, 54451,180, 54461,180, 54467,180, 54473,180, 54481,& - 180, 54503,180, 54511,180, 54517,180, 54551,180, 54553,& - 180, 54571,180, 54581,180, 54587,180, 54613,180, 54629,& - 180, 54643,180, 54647,180, 54659,180, 54677,180, 54683,& - 180, 54701,180, 54721,180, 54739,180, 54811,180, 54823,& - 180, 54829,180, 54833,180, 54839,180, 54869,180, 54871,& - 180, 54881,180, 54893,180, 54923,180, 54929,180, 54943,& - 180, 54967,180, 54971,180, 55001,180, 55013,180, 55039,& - 180, 55043,180, 55049,180, 55067,180, 55069,180, 55079,& - 180, 55097,180, 55109,180, 55111,180, 55117,180, 55123,& - 180, 55127,180, 55133,180, 55141,180, 55147,180, 55159,& - 180, 55193,180, 55201,180, 55247,180, 55273,180, 55279,& - 180, 55307,180, 55313,180, 55319,180, 55333,180, 55361,& - 180, 55379,180, 55387,180, 55411,180, 55429,180, 55439,& - 180, 55447,180, 55453,180, 55469,180, 55487,180, 55517,& - 180, 55537,180, 55571,180, 55573,180, 55579,180, 55603,& - 180, 55609,180, 55649,180, 55667,180, 55669,180, 55681,& - 180, 55691,180, 55697,180, 55729,180, 55741,180, 55757,& - 180, 55771,180, 55783,180, 55793,180, 55799,180, 55807,& - 180, 55813,180, 55817,180, 55823,180, 55831,180, 55847,& - 180, 55859,180, 55861,180, 55879,180, 55889,180, 55957,& - 180, 55973,180, 55979,180, 55993,180, 56033,180, 56051,& - 180, 56057,180, 56059,180, 56077,180, 56093,180, 56099,& - 180, 56111,180, 56129,180, 56131,180, 56143,180, 56161,& - 180, 56167,180, 56177,180, 56183,180, 56237,180, 56239,& - 180, 56261,180, 56279,180, 56287,180, 56293,180, 56323,& - 180, 56327,180, 56329,180, 56351,180, 56353,180, 56357,& - 180, 56377,180, 56393,180, 56399,180, 56411,180, 56437,& - 180, 56441,180, 56477,180, 56479,180, 56489,180, 56503,& - 180, 56509,180, 56521,180, 56533,180, 56539,180, 56551,& - 180, 56609,180, 56653,180, 56677,180, 56681,180, 56701,& - 180, 56723,180, 56737,180, 56741,180, 56747,180, 56761,& - 180, 56827,180, 56839,180, 56843,180, 56849,180, 56887,& - 180, 56903,180, 56939,180, 56941,180, 56947,180, 56969,& - 180, 56971,180, 56983,180, 57049,180, 57077,180, 57091,& - 180, 57121,180, 57133,180, 57137,180, 57149,180, 57169,& - 180, 57179,180, 57199,180, 57209,180, 57239,180, 57251,& - 180, 57277,180, 57281,180, 57293,180, 57311,180, 57337,& - 180, 57359,180, 57367,180, 57377,180, 57389,180, 57403,& - 180, 57407,180, 57409,180, 57413,180, 57419,180, 57431,& - 180, 57451,180, 57463,180, 57499,180, 57511,180, 57521,& - 180, 57529,180, 57539,180, 57577,180, 57581,180, 57667,& - 180, 57679,180, 57683,180, 57689,180, 57731,180, 57767,& - 180, 57781,180, 57787,180, 57799,180, 57823,180, 57847,& - 180, 57851,180, 57853,180, 57883,180, 57899,180, 57919,& - 180, 57931,180, 57949,180, 57953,180, 57959,180, 57961,& - 180, 57983,180, 57997,180, 58009,180, 58037,180, 58039,& - 180, 58043,180, 58049,180, 58087,180, 58091,180, 58093,& - 180, 58123,180, 58127,180, 58201,180, 58211,180, 58229,& - 180, 58243,180, 58277,180, 58303,180, 58313,180, 58333,& - 180, 58367,180, 58373,180, 58393,180, 58397,180, 58403,& - 180, 58411,180, 58417,180, 58421,180, 58439,180, 58457,& - 180, 58481,180, 58483,180, 58499,180, 58523,180, 58537,& - 180, 58543,180, 58549,180, 58553,180, 58631,180, 58661,& - 180, 58667,180, 58669,180, 58679,180, 58697,180, 58723,& - 180, 58733,180, 58739,180, 58751,180, 58787,180, 58789,& - 180, 58823,180, 58829,180, 58841,180, 58849,180, 58859,& - 180, 58871,180, 58873,180, 58877,180, 58879,180, 58901,& - 180, 58903,180, 58907,180, 58919,180, 58927,180, 58933,& - 180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ - DATA ((n(i,j),i=3,4),j=490,979)/ & - 180, 59069,180, 59071,180, 59087,180, 59101,180, 59107,& - 180, 59113,180, 59153,180, 59173,180, 59183,180, 59207,& - 180, 59209,180, 59219,180, 59233,180, 59251,180, 59257,& - 180, 59263,180, 59267,180, 59279,180, 59293,180, 59321,& - 180, 59327,180, 59333,180, 59347,180, 59359,180, 59389,& - 180, 59401,180, 59423,180, 59431,180, 59453,180, 59479,& - 180, 59509,180, 59513,180, 59519,180, 59521,180, 59543,& - 180, 59569,180, 59591,180, 59621,180, 59627,180, 59633,& - 180, 59659,180, 59671,180, 59681,180, 59699,180, 59713,& - 180, 59719,180, 59743,180, 59759,180, 59783,180, 59789,& - 180, 59801,180, 59807,180, 59827,180, 59831,180, 59849,& - 180, 59863,180, 59879,180, 59891,180, 59893,180, 59929,& - 180, 59939,180, 59981,180, 59989,180, 59993,180, 59999,& - 180, 60031,180, 60037,180, 60061,180, 60067,180, 60073,& - 180, 60103,180, 60149,180, 60161,180, 60173,180, 60179,& - 180, 60193,180, 60217,180, 60229,180, 60247,180, 60251,& - 180, 60283,180, 60329,180, 60331,180, 60341,180, 60361,& - 180, 60377,180, 60397,180, 60403,180, 60419,180, 60439,& - 180, 60467,180, 60473,180, 60499,180, 60523,180, 60553,& - 180, 60557,180, 60559,180, 60569,180, 60581,180, 60587,& - 180, 60593,180, 60601,180, 60611,180, 60613,180, 60619,& - 180, 60643,180, 60647,180, 60667,180, 60671,180, 60713,& - 180, 60737,180, 60749,180, 60763,180, 60769,180, 60787,& - 180, 60797,180, 60811,180, 60823,180, 60829,180, 60847,& - 180, 60851,180, 60853,180, 60881,180, 60887,180, 60889,& - 180, 60913,180, 60919,180, 60929,180, 60941,180, 60943,& - 180, 60971,180, 60973,180, 60977,180, 60997,180, 61001,& - 180, 61013,180, 61019,180, 61039,180, 61043,180, 61049,& - 180, 61063,180, 61081,180, 61109,180, 61111,180, 61133,& - 180, 61141,180, 61181,180, 61187,180, 61213,180, 61217,& - 180, 61229,180, 61231,180, 61271,180, 61273,180, 61279,& - 180, 61283,180, 61297,180, 61307,180, 61313,180, 61321,& - 180, 61337,180, 61339,180, 61351,180, 61357,180, 61393,& - 180, 61397,180, 61403,180, 61409,180, 61427,180, 61433,& - 180, 61451,180, 61489,180, 61511,180, 61519,180, 61529,& - 180, 61537,180, 61543,180, 61549,180, 61559,180, 61571,& - 180, 61577,180, 61579,180, 61621,180, 61631,180, 61651,& - 180, 61669,180, 61679,180, 61697,180, 61711,180, 61721,& - 180, 61747,180, 61763,180, 61787,180, 61789,180, 61799,& - 180, 61801,180, 61811,180, 61831,180, 61843,180, 61879,& - 180, 61897,180, 61901,180, 61907,180, 61943,180, 61963,& - 180, 61967,180, 61999,180, 62053,180, 62063,180, 62071,& - 180, 62077,180, 62089,180, 62093,180, 62099,180, 62117,& - 180, 62119,180, 62149,180, 62177,180, 62179,180, 62203,& - 180, 62221,180, 62239,180, 62243,180, 62249,180, 62267,& - 180, 62299,180, 62303,180, 62321,180, 62327,180, 62333,& - 180, 62359,180, 62371,180, 62413,180, 62417,180, 62441,& - 180, 62467,180, 62473,180, 62489,180, 62491,180, 62509,& - 180, 62537,180, 62551,180, 62569,180, 62581,180, 62593,& - 180, 62597,180, 62599,180, 62603,180, 62621,180, 62629,& - 180, 62657,180, 62659,180, 62671,180, 62677,180, 62683,& - 180, 62687,180, 62699,180, 62707,180, 62749,180, 62753,& - 180, 62761,180, 62767,180, 62789,180, 62813,180, 62827,& - 180, 62831,180, 62869,180, 62879,180, 62891,180, 62897,& - 180, 62903,180, 62947,180, 62953,180, 62971,180, 62977,& - 180, 62981,180, 62993,180, 63001,180, 63007,180, 63013,& - 180, 63023,180, 63029,180, 63059,180, 63061,180, 63083,& - 180, 63089,180, 63091,180, 63103,180, 63119,180, 63131,& - 180, 63163,180, 63227,180, 63233,180, 63239,180, 63259,& - 180, 63271,180, 63311,180, 63337,180, 63341,180, 63353,& - 180, 63367,180, 63373,180, 63397,180, 63409,180, 63413,& - 180, 63421,180, 63427,180, 63437,180, 63443,180, 63449,& - 180, 63481,180, 63499,180, 63509,180, 63517,180, 63541,& - 180, 63551,180, 63559,180, 63569,180, 63601,180, 63607,& - 180, 63617,180, 63623,180, 63629,180, 63637,180, 63653,& - 180, 63671,180, 63691,180, 63727,180, 63743,180, 63751,& - 180, 63763,180, 63787,180, 63821,180, 63827,180, 63847,& - 180, 63899,180, 63917,180, 63931,180, 63989,180, 63997,& - 180, 64003,180, 64007,180, 64009,180, 64013,180, 64037,& - 180, 64067,180, 64087,180, 64093,180, 64133,180, 64139,& - 180, 64147,180, 64157,180, 64163,180, 64169,180, 64181,& - 180, 64189,180, 64207,180, 64211,180, 64217,180, 64219,& - 180, 64223,180, 64247,180, 64261,180, 64273,180, 64297,& - 180, 64307,180, 64309,180, 64331,180, 64357,180, 64379,& - 180, 64387,180, 64409,180, 64417,180, 64483,180, 64489,& - 180, 64493,180, 64513,180, 64531,180, 64553,180, 64591,& - 180, 64601,180, 64609,180, 64613,180, 64619,180, 64627,& - 180, 64651,180, 64661,180, 64679,180, 64687,180, 64711,& - 180, 64717,180, 64727,180, 64739,180, 64741,180, 64751,& - 180, 64757,180, 64793,180, 64813,180, 64819,180, 64823,& - 180, 64847,180, 64871,180, 64877,180, 64883,180, 64891,& - 180, 64921,180, 64927,180, 64931,180, 64933,180, 64949,& - 180, 64961,180, 64987,180, 65047,180, 65059,180, 65063,& - 180, 65077,180, 65089,180, 65093,180, 65099,180, 65101,& - 180, 65119,180, 65131,180, 65137,180, 65147,180, 65159,& - 180, 65171,180, 65179,180, 65191,180, 65203,180, 65207,& - 180, 65213,180, 65221,180, 65231,180, 65233,180, 65269,& - 180, 65311,180, 65323,180, 65339,180, 65347,180, 65369,& - 180, 65393,180, 65399,180, 65407,180, 65431,180, 65437,& - 180, 65441,180, 65443,180, 65473,180, 65479,180, 65507,& - 180, 65527,180, 65533,181, 13,181, 15,181, 33,& - 181, 61,181, 67,181, 141,181, 151,181, 183,& - 181, 187,181, 201,181, 207,181, 213,181, 217,& - 181, 223,181, 225,181, 243,181, 253,181, 255,& - 181, 277,181, 291,181, 297,181, 301,181, 327,& - 181, 337,181, 357,181, 375,181, 423,181, 453,& - 181, 477,181, 511,181, 531,181, 547,181, 553,& - 181, 561,181, 565,181, 595,181, 607,181, 645/ - DATA ((n(i,j),i=3,4),j=980,nmax)/ & - 181, 657,181, 663,181, 685,181, 687,181, 697,& - 181, 745,181, 775,181, 787,181, 823,181, 825,& - 181, 841,181, 853,181, 865,181, 895,181, 903,& - 181, 943,181, 963,181, 973,181, 981,181, 1005,& - 181, 1015,181, 1021,181, 1023,181, 1041,181, 1051,& - 181, 1057,181, 1083,181, 1093,181, 1105,181, 1107,& - 181, 1117,181, 1135,181, 1137,181, 1155,181, 1167,& - 181, 1191,181, 1197,181, 1221,181, 1233,181, 1237,& - 181, 1243,181, 1263/ -! end -#endif -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! prng_32.f -!----------------------------------------------------------------------------- -#if defined(AIX) || defined(AMD64) - real(kind=8) function prng_next(me) -! implicit none - integer :: me -! -! Calling sequence: -! = prng_next ( ) -! = vprng ( , , ) -! -! This code is based on a sequential algorithm provided by Mal Kalos. -! This version uses a single 64-bit word to store the initial seeds -! and additive constants. -! A 64-bit floating point number is returned. -! -! The array "iparam" is full-word aligned, being padded by zeros to -! let each generator be on a subpage boundary. -! That is, rows 1 and 2 in a given column of the array are for real, -! rows 3-16 are bogus. -! -! July 12, 1993: double the number of sequences. We should have been -! using two packets per seed, rather than four -! October 31, 1993: merge the two arrays of seeds and constants, -! and switch to 64-bit arithmetic. -! June 1994: port to RS6K. Internal state is kept as 2 64-bit integers -! The ishft function is defined only on 32-bit integers, so we will -! shift numbers by dividing by 2**11 and then adding on 2**53-1. -! -! November 1994: ishift now works on 64-bit numbers (though it gives a -! warning). Thus we go back to using it. John Zollweg also added the -! vprng() routine to return vectors of real*8 random numbers. -! - real(kind=8),parameter :: recip53 = 2.0D0**(-53) - integer(kind=8),parameter :: two = 2**11 - integer(kind=8) :: m,ishift -! parameter ( m = 34522712143931 ) ! 11**13 -! parameter ( ishift = 9007199254740991 ) ! 2**53-1 - -!EL integer nmax -!EL integer*8 iparam -!EL parameter(nmax=1021) -!EL common/ksrprng/iparam(2,0:nmax) - - integer(kind=8) :: next - -!rc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - ishift = dint(9007199254740991.0d0) - if(me.gt.nmax) me=mod(me,nmax) - -! RS6K porting note: ishift now takes 64-bit integers , with a warning - if ( 0.le.me .and. me.le.nmax ) then - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - prng_next = recip53 * ishft( next, -11 ) - else - prng_next=-1.0D0 - endif - - end function prng_next -!----------------------------------------------------------------------------- -! -! vprng(me, rn, num) Get a vector of random numbers -! - subroutine vprng(me,rn,num) - - real(kind=8),parameter :: recip53 = 2.0D0**(-53) - real(kind=8),dimension(1) :: rn - - integer(kind=8) :: m -!EL ,iparam -! parameter ( m = 34522712143931 ) ! 11**13 -!EL integer nmax, - integer :: num, me,i -!EL parameter(nmax=1021) -!EL common/ksrprng/iparam(2,0:nmax) - - integer(kind=8) :: next - -!rc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - - if ( 0.le.me .and. me.le.nmax ) then - do 1 i=1,num - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - rn(i) = recip53 * ishft( next, -11 ) - 1 continue - else - rn(1)=-1.0D0 - endif - return - end subroutine vprng -!----------------------------------------------------------------------------- -! -! prng_chkpnt Get the current state of a generator -! -! Calling sequence: -! logical prng_chkpnt, status -! status = prng_chkpnt (me, iseed) where -! -! me is the particular generator whose state is being gotten -! seed is an 4-element integer array where the "l"-values will be saved -! - logical function prng_chkpnt(me,iseed) -! implicit none - integer :: me - integer(kind=8) :: iseed - -!EL integer nmax -!EL integer*8 iparam -!EL parameter(nmax=1021) -!EL common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed=iparam(1,me) - endif - end function prng_chkpnt -!----------------------------------------------------------------------------- -! -! prng_restart Restart generator from a saved state -! -! Calling sequence: -! logical prng_restart, status -! status = prng_restart (me, iseed) where -! -! me is the particular generator being restarted -! iseed is a 8-byte integer containing the "l"-values -! - logical function prng_restart(me,iseed) -! implicit none - integer :: me - integer(kind=8) :: iseed - -!EL integer nmax -!EL integer*8 iparam -!EL parameter(nmax=1021) -!EL common/ksrprng/iparam(2,0:nmax) - - if(me.gt.nmax) me=mod(me,nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - iparam(1,me)=iseed - endif - end function prng_restart -!----------------------------------------------------------------------------- -#else - real(kind=4) function prng_next(me) -!rc logical prng_restart, prng_chkpnt -! -! Calling sequence: -! = prng_next ( ) -! -! This code is based on a sequential algorithm provided by Mal Kalos. -! This version uses 4 16-bit packets, and uses a block data common -! area for the initial seeds and constants. A 64-bit floating point -! number is returned. -! -! The arrays "l" and "n" are full-word aligned, being padded by zeros -! That is, rows 1-4 in a given column are for real, rows 5-16 are bogus -! -! July 12, 1993: double the number of sequences. We should have been -! using two packets per seed, rather than four -! - real(kind=4),parameter :: tpm12 = 1.d0/65536.d0 - integer,dimension(4) :: iseed - integer :: me -!EL parameter(nmax=1021) -! external prngblk -!el integer,dimension(16,0:nmax) :: l,n -!EL common/ksrprng/l(16,0:nmax),n(16,0:nmax) -!*ksr*subpage /ksrprng/ - integer :: m1,m2,m3,m4,l1,l2,l3,l4,i1,i2,i3,i4 - data m1,m2,m3,m4 / 0, 8037, 61950, 30779/ - if (me .lt. 0 .or. me .gt. nmax) then - prng_next=-1.0 - return - endif - l1=l(1,me) - l2=l(2,me) - l3=l(3,me) - l4=l(4,me) - i1=l1*m4+l2*m3+l3*m2+l4*m1 + n(1,me) - i2=l2*m4+l3*m3+l4*m2 + n(2,me) - i3=l3*m4+l4*m3 + n(3,me) - i4=l4*m4 + n(4,me) - l4=and(i4,65535) - i3=i3+ishft(i4,-16) - l3=and(i3,65535) - i2=i2+ishft(i3,-16) - l2=and(i2,65535) - l1=and(i1+ishft(i2,-16),65535) - prng_next=tpm12*(l1+tpm12*(l2+tpm12*(l3+tpm12*l4))) - l(1,me)=l1 - l(2,me)=l2 - l(3,me)=l3 - l(4,me)=l4 - return - end function prng_next -!----------------------------------------------------------------------------- -! -! prng_chkpnt Get the current state of a generator -! -! Calling sequence: -! logical prng_chkpnt, status -! status = prng_chkpnt (me, iseed) where -! -! me is the particular generator whose state is being gotten -! seed is an 4-element integer array where the "l"-values will be saved -! -!rc entry prng_chkpnt (me, iseed) - logical function prng_chkpnt(me,iseed) - integer,dimension(4) :: iseed - integer :: me -!el parameter(nmax=1021) -!el common/ksrprng/l(16,0:nmax),n(16,0:nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed(1)=l(1,me) - iseed(2)=l(2,me) - iseed(3)=l(3,me) - iseed(4)=l(4,me) - endif - return - end function prng_chkpnt -!----------------------------------------------------------------------------- -! prng_restart Restart generator from a saved state -! -! Calling sequence: -! logical prng_restart, status -! status = prng_restart (me, iseed) where -! -! me is the particular generator being restarted -! seed is an 4-element integer array containing the "l"-values -! -!rc entry prng_restart (me, iseed) - logical function prng_restart(me,iseed) - - integer,dimension(4) :: iseed - integer :: me -!el parameter(nmax=1021) -!el common/ksrprng/l(16,0:nmax),n(16,0:nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - l(1,me)=iseed(1) - l(2,me)=iseed(2) - l(3,me)=iseed(3) - l(4,me)=iseed(4) - endif - return - end function prng_restart -#endif -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module prng diff --git a/source/unres/random.F90 b/source/unres/random.F90 new file mode 100644 index 0000000..fa14312 --- /dev/null +++ b/source/unres/random.F90 @@ -0,0 +1,577 @@ + module random +!----------------------------------------------------------------------------- + use io_units + use prng ! prng.f90 or prng_32.f90 + use math + implicit none +! public :: rndv +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! gen_rand_conf.F +!----------------------------------------------------------------------------- + real(kind=8) function ran_number(x1,x2) +! Calculate a random real number from the range (x1,x2). +#ifdef MPI + use MPI_data ! include 'COMMON.SETUP' + include "mpif.h" +#endif + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + real(kind=8) :: x1,x2,fctor +!el local variables + integer :: ix(1) !el ix ---> ix(1) + data fctor /2147483647.0D0/ +#ifdef MPI + ran_number=x1+(x2-x1)*prng_next(me) +#else + call vrnd(ix(1),1) + ran_number=x1+(x2-x1)*ix(1)/fctor +#endif + return + end function ran_number +!----------------------------------------------------------------------------- + integer function iran_num(n1,n2) +! Calculate a random integer number from the range (n1,n2). +#ifdef MPI + use MPI_data ! include 'COMMON.SETUP' + include "mpif.h" +#endif +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer :: n1,n2,ix(1) !el ix ---> ix(1) + real(kind=4) :: fctor=2147483647.0 +#ifdef MPI + ix(1)=n1+(n2-n1+1)*prng_next(me) + if (ix(1).lt.n1) ix(1)=n1 + if (ix(1).gt.n2) ix(1)=n2 + iran_num=ix(1) +#else + call vrnd(ix(1),1) + ix(1)=n1+(n2-n1+1)*(ix(1)/fctor) + if (ix(1).gt.n2) ix(1)=n2 + iran_num=ix(1) +#endif + return + end function iran_num +!----------------------------------------------------------------------------- + real(kind=8) function binorm(x1,x2,sigma1,sigma2,ak) +! implicit real*8 (a-h,o-z) +!el local variables + real(kind=8) :: x1,x2,sigma1,sigma2,ak,alowb,aupb,seg,alen +! print '(a)','Enter BINORM.' + alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2) + aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2) + seg=sigma1/(sigma1+ak*sigma2) + alen=ran_number(0.0D0,1.0D0) + if (alen.lt.seg) then + binorm=anorm_distr(x1,sigma1,alowb,aupb) + else + binorm=anorm_distr(x2,sigma2,alowb,aupb) + endif +! print '(a)','Exiting BINORM.' + return + end function binorm +!----------------------------------------------------------------------------- + real(kind=8) function anorm_distr(x,sigma,alowb,aupb) +! implicit real*8 (a-h,o-z) +! to make a normally distributed deviate with zero mean and unit variance +! + integer :: iset + real(kind=8) :: fac,gset,rsq,v1,v2,ran1 + real(kind=8) :: x,sigma,alowb,aupb,gaussdev + save iset,gset + data iset/0/ +!elwrite(iout,*) "anorm distr start",x,sigma,alowb,aupb + if(iset.eq.0) then + 1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 + v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 + rsq=v1**2+v2**2 + if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1 + fac=sqrt(-2.0d0*log(rsq)/rsq) + gset=v1*fac + gaussdev=v2*fac + iset=1 + else + gaussdev=gset + iset=0 + endif + anorm_distr=x+gaussdev*sigma +!elwrite(iout,*) "anorm distr end",x,sigma,alowb,aupb,anorm_distr + return + end function anorm_distr +!----------------------------------------------------------------------------- + subroutine mult_norm(lda,n,a,x,fail) +! +! Generate the vector X whose elements obey the multiple-normal distribution +! from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A, +! n is the dimension of the problem. FAIL is set at .TRUE., if the smallest +! eigenvalue of the matrix A is close to 0. +! +! implicit double precision (a-h,o-z) + integer :: lda,n,i,j + real(kind=8),dimension(lda,n) :: a + real(kind=8),dimension(n) :: x + real(kind=8),dimension(100) :: eig,work + real(kind=8),dimension(3,3) :: vec + real(kind=8) :: eig_limit=1.0D-8 + logical :: fail + real(kind=8) :: sigma,alim,xi + fail=.false. +! print '(a)','Enter MULT_NORM.' +! +! Find the smallest eigenvalue of the matrix A. +! +! do i=1,n +! print '(8f10.5)',(a(i,j),j=1,n) +! enddo +#ifdef NAG + call f02faf('V','U',2,a,lda,eig,work,100,ifail) +#else + call djacob(2,lda,10000,1.0d-10,a,vec,eig) +#endif +! print '(8f10.5)',(eig(i),i=1,n) +! print '(a)' +! do i=1,n +! print '(8f10.5)',(a(i,j),j=1,n) +! enddo + if (eig(1).lt.eig_limit) then + print *,'From Mult_Norm: Eigenvalues of A are too small.' + fail=.true. + return + endif +! +! Generate points following the normal distributions along the principal +! axes of the moment matrix. Store in WORK. +! + do i=1,n + sigma=1.0D0/dsqrt(eig(i)) + alim=-3.0D0*sigma + work(i)=anorm_distr(0.0D0,sigma,-alim,alim) + enddo +! +! Transform the vector of normal variables back to the original basis. +! + do i=1,n + xi=0.0D0 + do j=1,n + xi=xi+a(i,j)*work(j) + enddo + x(i)=xi + enddo + return + end subroutine mult_norm +!----------------------------------------------------------------------------- + subroutine mult_norm1(lda,n,a,z,box,x,fail) +! +! Generate the vector X whose elements obey the multi-gaussian multi-dimensional +! distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the +! leading dimension of the moment matrix A, n is the dimension of the +! distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the +! smallest eigenvalue of the matrix A is close to 0. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MP + use MPI_data !include 'COMMON.SETUP' +#endif +#ifdef MPI + include 'mpif.h' +#endif + integer :: lda,n,i,j,istep + real(kind=8),dimension(lda,n) :: a + real(kind=8),dimension(n) :: z,x + real(kind=8),dimension(n,n) :: box + real(kind=8) :: etmp,ww,xi,dec +! include 'COMMON.IOUNITS' + logical :: fail +! +! Generate points following the normal distributions along the principal +! axes of the moment matrix. Store in WORK. +! +!d print *,'CG Processor',me,' entered MultNorm1.' +!d print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2) +!d do i=1,n +!d print *,i,box(1,i),box(2,i) +!d enddo + istep = 0 + 10 istep = istep + 1 + if (istep.gt.10000) then +! write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', +! & ' in MultNorm1.' +! write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', +! & ' in MultNorm1.' +! write (iout,*) 'box',box +! write (iout,*) 'a',a +! write (iout,*) 'z',z + fail=.true. + return + endif + do i=1,n + x(i)=ran_number(box(1,i),box(2,i)) + enddo + ww=0.0D0 + do i=1,n + xi=pinorm(x(i)-z(i)) + ww=ww+0.5D0*a(i,i)*xi*xi + do j=i+1,n + ww=ww+a(i,j)*xi*pinorm(x(j)-z(j)) + enddo + enddo + dec=ran_number(0.0D0,1.0D0) +! print *,(x(i),i=1,n),ww,dexp(-ww),dec +!rc if (dec.gt.dexp(-ww)) goto 10 + if(-ww.lt.100) then + etmp=dexp(-ww) + else + return + endif + if (dec.gt.etmp) goto 10 +!d print *,'CG Processor',me,' exitting MultNorm1.' + return + end subroutine mult_norm1 +!----------------------------------------------------------------------------- +! ran.f +!----------------------------------------------------------------------------- + function ran0(idum) + integer :: idum + integer,parameter :: IA=16807,IM=2147483647,IQ=127773,IR=2836 + integer,parameter :: MASK=123459876 + real(kind=4) :: ran0 + real(kind=4),parameter :: AM=1./IM + integer :: k + idum=ieor(idum,MASK) + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + ran0=AM*idum + idum=ieor(idum,MASK) + return + end function ran0 +! (C) Copr. 1986-92 Numerical Recipes Software *11915 +!----------------------------------------------------------------------------- + function ran1(idum) + integer :: idum + integer,parameter :: IA=16807,IM=2147483647,IQ=127773,IR=2836 + integer,parameter :: NTAB=32,NDIV=1+(IM-1)/NTAB + real(kind=4) :: ran1 + real(kind=4),parameter :: AM=1./IM,EPS=1.2e-7,RNMX=1.-EPS + integer :: j,k,iy + integer,dimension(NTAB) :: iv + SAVE iv,iy + DATA iv /NTAB*0/, iy /0/ + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do 11 j=NTAB+8,1,-1 + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + j=1+iy/NDIV + iy=iv(j) + iv(j)=idum + ran1=min(AM*iy,RNMX) + return + end function ran1 +! (C) Copr. 1986-92 Numerical Recipes Software *11915 +!----------------------------------------------------------------------------- + function ran2(idum) + integer :: idum + integer,parameter :: IM1=2147483563,IM2=2147483399,IMM1=IM1-1,& + IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791,& + NTAB=32,NDIV=1+IMM1/NTAB + real(kind=4) :: ran2 + real(kind=4),parameter :: AM=1./IM1,EPS=1.2e-7,RNMX=1.-EPS + integer :: idum2,j,k,iy + integer,dimension(NTAB) :: iv + SAVE iv,iy,idum2 + DATA idum2/123456789/, iv/NTAB*0/, iy/0/ + if (idum.le.0) then + idum=max(-idum,1) + idum2=idum + do 11 j=NTAB+8,1,-1 + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + k=idum2/IQ2 + idum2=IA2*(idum2-k*IQ2)-k*IR2 + if (idum2.lt.0) idum2=idum2+IM2 + j=1+iy/NDIV + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+IMM1 + ran2=min(AM*iy,RNMX) + return + end function ran2 +! (C) Copr. 1986-92 Numerical Recipes Software *11915 +!----------------------------------------------------------------------------- + function ran3(idum) + integer :: idum + integer,parameter :: MBIG=1000000000,MSEED=161803398,MZ=0 +! REAL MBIG,MSEED,MZ + real(kind=4) :: ran3 + real(kind=4),parameter :: FAC=1./MBIG +! PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG) + integer :: i,iff,ii,inext,inextp,k + integer :: mj,mk + integer,dimension(55) :: ma +! REAL mj,mk,ma(55) + SAVE iff,inext,inextp,ma + DATA iff /0/ + if(idum.lt.0.or.iff.eq.0)then + iff=1 + mj=MSEED-iabs(idum) + mj=mod(mj,MBIG) + ma(55)=mj + mk=1 + do 11 i=1,54 + ii=mod(21*i,55) + ma(ii)=mk + mk=mj-mk + if(mk.lt.MZ)mk=mk+MBIG + mj=ma(ii) +11 continue + do 13 k=1,4 + do 12 i=1,55 + ma(i)=ma(i)-ma(1+mod(i+30,55)) + if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG +12 continue +13 continue + inext=0 + inextp=31 + idum=1 + endif + inext=inext+1 + if(inext.eq.56)inext=1 + inextp=inextp+1 + if(inextp.eq.56)inextp=1 + mj=ma(inext)-ma(inextp) + if(mj.lt.MZ)mj=mj+MBIG + ma(inext)=mj + ran3=mj*FAC + return + end function ran3 +! (C) Copr. 1986-92 Numerical Recipes Software *11915 +!----------------------------------------------------------------------------- +! randgens.f +!----------------------------------------------------------------------------- +! $Date: 1994/10/04 16:19:52 $ +! $Revision: 2.1 $ +! +! +! See help for RANDOMV on the PSFSHARE disk to understand these +! subroutines. This is the VS Fortran version of this code. +! +! + subroutine VRND(VEC,N) + + use comm_vrandd +!el integer,dimension(250) :: A + integer :: LOOP,N !el,I,I147 + integer,dimension(N) :: VEC +!el COMMON /VRANDD/ A, I, I147 + DO 23000 LOOP=1,N + I=I+1 + IF(.NOT.(I.GE.251))GOTO 23002 + I=1 +23002 CONTINUE + I147=I147+1 + IF(.NOT.(I147.GE.251))GOTO 23004 + I147=1 +23004 CONTINUE + A(I)=IEOR(A(I147),A(I)) + VEC(LOOP)=A(I) +23000 CONTINUE + return + end subroutine VRND +!----------------------------------------------------------------------------- + real(kind=8) function RNDV(IDUM) + + real(kind=8) :: RM1,RM2,R(99) + INTEGER :: IA1,IC1,M1, IA2,IC2,M2, IA3,IC3,M3, IDUM + INTEGER :: IX1,IX2,IX3,J + SAVE + DATA IA1,IC1,M1/1279,351762,1664557/ + DATA IA2,IC2,M2/2011,221592,1048583/ + DATA IA3,IC3,M3/15551,6150,29101/ + IF(.NOT.(IDUM.LT.0))GOTO 23006 + IX1 = MOD(-IDUM,M1) + IX1 = MOD(IA1*IX1+IC1,M1) + IX2 = MOD(IX1,M2) + IX1 = MOD(IA1*IX1+IC1,M1) + IX3 = MOD(IX1,M3) + RM1 = 1./DBLE(M1) + RM2 = 1./DBLE(M2) + DO 23008 J = 1,99 + IX1 = MOD(IA1*IX1+IC1,M1) + IX2 = MOD(IA2*IX2+IC2,M2) + R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 +23008 CONTINUE +23006 CONTINUE + IX1 = MOD(IA1*IX1+IC1,M1) + IX2 = MOD(IA2*IX2+IC2,M2) + IX3 = MOD(IA3*IX3+IC3,M3) + J = 1+(99*IX3)/M3 + RNDV = R(J) + R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 + IDUM = IX1 + return + end function RNDV +!----------------------------------------------------------------------------- + subroutine VRNDST(SEED) + + use comm_vrandd +!el INTEGER :: A(250) + INTEGER :: LOOP,IDUM !el,I,I147 + INTEGER :: SEED +!el real(kind=8) :: RNDV +!el COMMON /VRANDD/ A, I, I147 + I=0 + I147=103 + IDUM=SEED + DO 23010 LOOP=1,250 + A(LOOP)=INT(RNDV(IDUM)*2147483647) +23010 CONTINUE + return + end subroutine VRNDST +!----------------------------------------------------------------------------- + subroutine VRNDIN(IODEV) + use comm_vrandd + INTEGER :: IODEV !el, A(250),I, I147 +!el COMMON/VRANDD/ A, I, I147 + READ(IODEV) A, I, I147 + return + end subroutine VRNDIN +!----------------------------------------------------------------------------- + subroutine VRNDOU(IODEV) +! This corresponds to VRNDOUT in the APFTN64 version + use comm_vrandd + INTEGER :: IODEV !el, A(250),I, I147 +!el COMMON/VRANDD/ A, I, I147 + WRITE(IODEV) A, I, I147 + return + end subroutine VRNDOU +!----------------------------------------------------------------------------- + real(kind=8) function RNUNF(N) + INTEGER :: IRAN1(2000),N + real(kind=8) :: FCTOR + DATA FCTOR /2147483647.0D0/ +! We get only one random number, here! DR 9/1/92 + CALL VRND(IRAN1,1) + RNUNF= DBLE( IRAN1(1) ) / FCTOR +!****************************** +! write(6,*) 'rnunf in rnunf = ',rnunf + return + end function RNUNF +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + subroutine random_init(seed) +! +! Initialize random number generator +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + use MPI_data + include 'mpif.h' + logical :: OKRandom !, prng_restart + real(kind=8) :: r1 + integer :: iseed_array(4) + integer(kind=8) :: iseed +#else + integer :: iseed +#endif + real(kind=8) :: seed + integer :: ierr,error_msg +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.THREAD' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.MCM' +! include 'COMMON.MAP' +! include 'COMMON.HEADER' +! include 'COMMON.CSA' +! include 'COMMON.CHAIN' +! include 'COMMON.MUCA' +! include 'COMMON.MD' +! include 'COMMON.FFIELD' +! include 'COMMON.SETUP' + iseed=-dint(dabs(seed)) + if (iseed.eq.0) then + write (iout,'(/80(1h*)/20x,a/80(1h*))') & + 'Random seed undefined. The program will stop.' + write (*,'(/80(1h*)/20x,a/80(1h*))') & + 'Random seed undefined. The program will stop.' +#ifdef MPI + call mpi_finalize(mpi_comm_world,ierr) +#endif + stop 'Bad random seed.' + endif +#ifdef MPI + if (fg_rank.eq.0) then + seed=seed*(me+1)+1 +#ifdef AMD64 + if(me.eq.king) & + write (iout,*) 'MPI: node= ', me, ' iseed= ',iseed + OKRandom = prng_restart(me,iseed) +#else + do i=1,4 + tmp=65536.0d0**(4-i) + iseed_array(i) = dint(seed/tmp) + seed=seed-iseed_array(i)*tmp + enddo + if(me.eq.king) & + write (iout,*) 'MPI: node= ', me, ' iseed(4)= ',& + (iseed_array(i),i=1,4) + write (*,*) 'MPI: node= ',me, ' iseed(4)= ',& + (iseed_array(i),i=1,4) + OKRandom = prng_restart(me,iseed_array) +#endif + if (OKRandom) then +! r1 = prng_next(me) + r1=ran_number(0.0D0,1.0D0) + if(me.eq.king) & + write (iout,*) 'ran_num',r1 + if (r1.lt.0.0d0) OKRandom=.false. + endif + if (.not.OKRandom) then + write (iout,*) 'PRNG IS NOT WORKING!!!' + print *,'PRNG IS NOT WORKING!!!' + if (me.eq.0) then + call flush(iout) + call mpi_abort(mpi_comm_world,error_msg,ierr) + stop + else + write (iout,*) 'too many processors for parallel prng' + write (*,*) 'too many processors for parallel prng' + call flush(iout) + stop + endif + endif + endif +#else + call vrndst(iseed) + write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0) +#endif + return + end subroutine random_init +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module random diff --git a/source/unres/random.f90 b/source/unres/random.f90 deleted file mode 100644 index fa14312..0000000 --- a/source/unres/random.f90 +++ /dev/null @@ -1,577 +0,0 @@ - module random -!----------------------------------------------------------------------------- - use io_units - use prng ! prng.f90 or prng_32.f90 - use math - implicit none -! public :: rndv -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! gen_rand_conf.F -!----------------------------------------------------------------------------- - real(kind=8) function ran_number(x1,x2) -! Calculate a random real number from the range (x1,x2). -#ifdef MPI - use MPI_data ! include 'COMMON.SETUP' - include "mpif.h" -#endif - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - real(kind=8) :: x1,x2,fctor -!el local variables - integer :: ix(1) !el ix ---> ix(1) - data fctor /2147483647.0D0/ -#ifdef MPI - ran_number=x1+(x2-x1)*prng_next(me) -#else - call vrnd(ix(1),1) - ran_number=x1+(x2-x1)*ix(1)/fctor -#endif - return - end function ran_number -!----------------------------------------------------------------------------- - integer function iran_num(n1,n2) -! Calculate a random integer number from the range (n1,n2). -#ifdef MPI - use MPI_data ! include 'COMMON.SETUP' - include "mpif.h" -#endif -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer :: n1,n2,ix(1) !el ix ---> ix(1) - real(kind=4) :: fctor=2147483647.0 -#ifdef MPI - ix(1)=n1+(n2-n1+1)*prng_next(me) - if (ix(1).lt.n1) ix(1)=n1 - if (ix(1).gt.n2) ix(1)=n2 - iran_num=ix(1) -#else - call vrnd(ix(1),1) - ix(1)=n1+(n2-n1+1)*(ix(1)/fctor) - if (ix(1).gt.n2) ix(1)=n2 - iran_num=ix(1) -#endif - return - end function iran_num -!----------------------------------------------------------------------------- - real(kind=8) function binorm(x1,x2,sigma1,sigma2,ak) -! implicit real*8 (a-h,o-z) -!el local variables - real(kind=8) :: x1,x2,sigma1,sigma2,ak,alowb,aupb,seg,alen -! print '(a)','Enter BINORM.' - alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2) - aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2) - seg=sigma1/(sigma1+ak*sigma2) - alen=ran_number(0.0D0,1.0D0) - if (alen.lt.seg) then - binorm=anorm_distr(x1,sigma1,alowb,aupb) - else - binorm=anorm_distr(x2,sigma2,alowb,aupb) - endif -! print '(a)','Exiting BINORM.' - return - end function binorm -!----------------------------------------------------------------------------- - real(kind=8) function anorm_distr(x,sigma,alowb,aupb) -! implicit real*8 (a-h,o-z) -! to make a normally distributed deviate with zero mean and unit variance -! - integer :: iset - real(kind=8) :: fac,gset,rsq,v1,v2,ran1 - real(kind=8) :: x,sigma,alowb,aupb,gaussdev - save iset,gset - data iset/0/ -!elwrite(iout,*) "anorm distr start",x,sigma,alowb,aupb - if(iset.eq.0) then - 1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - rsq=v1**2+v2**2 - if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1 - fac=sqrt(-2.0d0*log(rsq)/rsq) - gset=v1*fac - gaussdev=v2*fac - iset=1 - else - gaussdev=gset - iset=0 - endif - anorm_distr=x+gaussdev*sigma -!elwrite(iout,*) "anorm distr end",x,sigma,alowb,aupb,anorm_distr - return - end function anorm_distr -!----------------------------------------------------------------------------- - subroutine mult_norm(lda,n,a,x,fail) -! -! Generate the vector X whose elements obey the multiple-normal distribution -! from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A, -! n is the dimension of the problem. FAIL is set at .TRUE., if the smallest -! eigenvalue of the matrix A is close to 0. -! -! implicit double precision (a-h,o-z) - integer :: lda,n,i,j - real(kind=8),dimension(lda,n) :: a - real(kind=8),dimension(n) :: x - real(kind=8),dimension(100) :: eig,work - real(kind=8),dimension(3,3) :: vec - real(kind=8) :: eig_limit=1.0D-8 - logical :: fail - real(kind=8) :: sigma,alim,xi - fail=.false. -! print '(a)','Enter MULT_NORM.' -! -! Find the smallest eigenvalue of the matrix A. -! -! do i=1,n -! print '(8f10.5)',(a(i,j),j=1,n) -! enddo -#ifdef NAG - call f02faf('V','U',2,a,lda,eig,work,100,ifail) -#else - call djacob(2,lda,10000,1.0d-10,a,vec,eig) -#endif -! print '(8f10.5)',(eig(i),i=1,n) -! print '(a)' -! do i=1,n -! print '(8f10.5)',(a(i,j),j=1,n) -! enddo - if (eig(1).lt.eig_limit) then - print *,'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif -! -! Generate points following the normal distributions along the principal -! axes of the moment matrix. Store in WORK. -! - do i=1,n - sigma=1.0D0/dsqrt(eig(i)) - alim=-3.0D0*sigma - work(i)=anorm_distr(0.0D0,sigma,-alim,alim) - enddo -! -! Transform the vector of normal variables back to the original basis. -! - do i=1,n - xi=0.0D0 - do j=1,n - xi=xi+a(i,j)*work(j) - enddo - x(i)=xi - enddo - return - end subroutine mult_norm -!----------------------------------------------------------------------------- - subroutine mult_norm1(lda,n,a,z,box,x,fail) -! -! Generate the vector X whose elements obey the multi-gaussian multi-dimensional -! distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the -! leading dimension of the moment matrix A, n is the dimension of the -! distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the -! smallest eigenvalue of the matrix A is close to 0. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MP - use MPI_data !include 'COMMON.SETUP' -#endif -#ifdef MPI - include 'mpif.h' -#endif - integer :: lda,n,i,j,istep - real(kind=8),dimension(lda,n) :: a - real(kind=8),dimension(n) :: z,x - real(kind=8),dimension(n,n) :: box - real(kind=8) :: etmp,ww,xi,dec -! include 'COMMON.IOUNITS' - logical :: fail -! -! Generate points following the normal distributions along the principal -! axes of the moment matrix. Store in WORK. -! -!d print *,'CG Processor',me,' entered MultNorm1.' -!d print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2) -!d do i=1,n -!d print *,i,box(1,i),box(2,i) -!d enddo - istep = 0 - 10 istep = istep + 1 - if (istep.gt.10000) then -! write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -! & ' in MultNorm1.' -! write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -! & ' in MultNorm1.' -! write (iout,*) 'box',box -! write (iout,*) 'a',a -! write (iout,*) 'z',z - fail=.true. - return - endif - do i=1,n - x(i)=ran_number(box(1,i),box(2,i)) - enddo - ww=0.0D0 - do i=1,n - xi=pinorm(x(i)-z(i)) - ww=ww+0.5D0*a(i,i)*xi*xi - do j=i+1,n - ww=ww+a(i,j)*xi*pinorm(x(j)-z(j)) - enddo - enddo - dec=ran_number(0.0D0,1.0D0) -! print *,(x(i),i=1,n),ww,dexp(-ww),dec -!rc if (dec.gt.dexp(-ww)) goto 10 - if(-ww.lt.100) then - etmp=dexp(-ww) - else - return - endif - if (dec.gt.etmp) goto 10 -!d print *,'CG Processor',me,' exitting MultNorm1.' - return - end subroutine mult_norm1 -!----------------------------------------------------------------------------- -! ran.f -!----------------------------------------------------------------------------- - function ran0(idum) - integer :: idum - integer,parameter :: IA=16807,IM=2147483647,IQ=127773,IR=2836 - integer,parameter :: MASK=123459876 - real(kind=4) :: ran0 - real(kind=4),parameter :: AM=1./IM - integer :: k - idum=ieor(idum,MASK) - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - ran0=AM*idum - idum=ieor(idum,MASK) - return - end function ran0 -! (C) Copr. 1986-92 Numerical Recipes Software *11915 -!----------------------------------------------------------------------------- - function ran1(idum) - integer :: idum - integer,parameter :: IA=16807,IM=2147483647,IQ=127773,IR=2836 - integer,parameter :: NTAB=32,NDIV=1+(IM-1)/NTAB - real(kind=4) :: ran1 - real(kind=4),parameter :: AM=1./IM,EPS=1.2e-7,RNMX=1.-EPS - integer :: j,k,iy - integer,dimension(NTAB) :: iv - SAVE iv,iy - DATA iv /NTAB*0/, iy /0/ - if (idum.le.0.or.iy.eq.0) then - idum=max(-idum,1) - do 11 j=NTAB+8,1,-1 - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - j=1+iy/NDIV - iy=iv(j) - iv(j)=idum - ran1=min(AM*iy,RNMX) - return - end function ran1 -! (C) Copr. 1986-92 Numerical Recipes Software *11915 -!----------------------------------------------------------------------------- - function ran2(idum) - integer :: idum - integer,parameter :: IM1=2147483563,IM2=2147483399,IMM1=IM1-1,& - IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791,& - NTAB=32,NDIV=1+IMM1/NTAB - real(kind=4) :: ran2 - real(kind=4),parameter :: AM=1./IM1,EPS=1.2e-7,RNMX=1.-EPS - integer :: idum2,j,k,iy - integer,dimension(NTAB) :: iv - SAVE iv,iy,idum2 - DATA idum2/123456789/, iv/NTAB*0/, iy/0/ - if (idum.le.0) then - idum=max(-idum,1) - idum2=idum - do 11 j=NTAB+8,1,-1 - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - ran2=min(AM*iy,RNMX) - return - end function ran2 -! (C) Copr. 1986-92 Numerical Recipes Software *11915 -!----------------------------------------------------------------------------- - function ran3(idum) - integer :: idum - integer,parameter :: MBIG=1000000000,MSEED=161803398,MZ=0 -! REAL MBIG,MSEED,MZ - real(kind=4) :: ran3 - real(kind=4),parameter :: FAC=1./MBIG -! PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG) - integer :: i,iff,ii,inext,inextp,k - integer :: mj,mk - integer,dimension(55) :: ma -! REAL mj,mk,ma(55) - SAVE iff,inext,inextp,ma - DATA iff /0/ - if(idum.lt.0.or.iff.eq.0)then - iff=1 - mj=MSEED-iabs(idum) - mj=mod(mj,MBIG) - ma(55)=mj - mk=1 - do 11 i=1,54 - ii=mod(21*i,55) - ma(ii)=mk - mk=mj-mk - if(mk.lt.MZ)mk=mk+MBIG - mj=ma(ii) -11 continue - do 13 k=1,4 - do 12 i=1,55 - ma(i)=ma(i)-ma(1+mod(i+30,55)) - if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG -12 continue -13 continue - inext=0 - inextp=31 - idum=1 - endif - inext=inext+1 - if(inext.eq.56)inext=1 - inextp=inextp+1 - if(inextp.eq.56)inextp=1 - mj=ma(inext)-ma(inextp) - if(mj.lt.MZ)mj=mj+MBIG - ma(inext)=mj - ran3=mj*FAC - return - end function ran3 -! (C) Copr. 1986-92 Numerical Recipes Software *11915 -!----------------------------------------------------------------------------- -! randgens.f -!----------------------------------------------------------------------------- -! $Date: 1994/10/04 16:19:52 $ -! $Revision: 2.1 $ -! -! -! See help for RANDOMV on the PSFSHARE disk to understand these -! subroutines. This is the VS Fortran version of this code. -! -! - subroutine VRND(VEC,N) - - use comm_vrandd -!el integer,dimension(250) :: A - integer :: LOOP,N !el,I,I147 - integer,dimension(N) :: VEC -!el COMMON /VRANDD/ A, I, I147 - DO 23000 LOOP=1,N - I=I+1 - IF(.NOT.(I.GE.251))GOTO 23002 - I=1 -23002 CONTINUE - I147=I147+1 - IF(.NOT.(I147.GE.251))GOTO 23004 - I147=1 -23004 CONTINUE - A(I)=IEOR(A(I147),A(I)) - VEC(LOOP)=A(I) -23000 CONTINUE - return - end subroutine VRND -!----------------------------------------------------------------------------- - real(kind=8) function RNDV(IDUM) - - real(kind=8) :: RM1,RM2,R(99) - INTEGER :: IA1,IC1,M1, IA2,IC2,M2, IA3,IC3,M3, IDUM - INTEGER :: IX1,IX2,IX3,J - SAVE - DATA IA1,IC1,M1/1279,351762,1664557/ - DATA IA2,IC2,M2/2011,221592,1048583/ - DATA IA3,IC3,M3/15551,6150,29101/ - IF(.NOT.(IDUM.LT.0))GOTO 23006 - IX1 = MOD(-IDUM,M1) - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IX1,M2) - IX1 = MOD(IA1*IX1+IC1,M1) - IX3 = MOD(IX1,M3) - RM1 = 1./DBLE(M1) - RM2 = 1./DBLE(M2) - DO 23008 J = 1,99 - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 -23008 CONTINUE -23006 CONTINUE - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - IX3 = MOD(IA3*IX3+IC3,M3) - J = 1+(99*IX3)/M3 - RNDV = R(J) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 - IDUM = IX1 - return - end function RNDV -!----------------------------------------------------------------------------- - subroutine VRNDST(SEED) - - use comm_vrandd -!el INTEGER :: A(250) - INTEGER :: LOOP,IDUM !el,I,I147 - INTEGER :: SEED -!el real(kind=8) :: RNDV -!el COMMON /VRANDD/ A, I, I147 - I=0 - I147=103 - IDUM=SEED - DO 23010 LOOP=1,250 - A(LOOP)=INT(RNDV(IDUM)*2147483647) -23010 CONTINUE - return - end subroutine VRNDST -!----------------------------------------------------------------------------- - subroutine VRNDIN(IODEV) - use comm_vrandd - INTEGER :: IODEV !el, A(250),I, I147 -!el COMMON/VRANDD/ A, I, I147 - READ(IODEV) A, I, I147 - return - end subroutine VRNDIN -!----------------------------------------------------------------------------- - subroutine VRNDOU(IODEV) -! This corresponds to VRNDOUT in the APFTN64 version - use comm_vrandd - INTEGER :: IODEV !el, A(250),I, I147 -!el COMMON/VRANDD/ A, I, I147 - WRITE(IODEV) A, I, I147 - return - end subroutine VRNDOU -!----------------------------------------------------------------------------- - real(kind=8) function RNUNF(N) - INTEGER :: IRAN1(2000),N - real(kind=8) :: FCTOR - DATA FCTOR /2147483647.0D0/ -! We get only one random number, here! DR 9/1/92 - CALL VRND(IRAN1,1) - RNUNF= DBLE( IRAN1(1) ) / FCTOR -!****************************** -! write(6,*) 'rnunf in rnunf = ',rnunf - return - end function RNUNF -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - subroutine random_init(seed) -! -! Initialize random number generator -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - use MPI_data - include 'mpif.h' - logical :: OKRandom !, prng_restart - real(kind=8) :: r1 - integer :: iseed_array(4) - integer(kind=8) :: iseed -#else - integer :: iseed -#endif - real(kind=8) :: seed - integer :: ierr,error_msg -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.THREAD' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.MCM' -! include 'COMMON.MAP' -! include 'COMMON.HEADER' -! include 'COMMON.CSA' -! include 'COMMON.CHAIN' -! include 'COMMON.MUCA' -! include 'COMMON.MD' -! include 'COMMON.FFIELD' -! include 'COMMON.SETUP' - iseed=-dint(dabs(seed)) - if (iseed.eq.0) then - write (iout,'(/80(1h*)/20x,a/80(1h*))') & - 'Random seed undefined. The program will stop.' - write (*,'(/80(1h*)/20x,a/80(1h*))') & - 'Random seed undefined. The program will stop.' -#ifdef MPI - call mpi_finalize(mpi_comm_world,ierr) -#endif - stop 'Bad random seed.' - endif -#ifdef MPI - if (fg_rank.eq.0) then - seed=seed*(me+1)+1 -#ifdef AMD64 - if(me.eq.king) & - write (iout,*) 'MPI: node= ', me, ' iseed= ',iseed - OKRandom = prng_restart(me,iseed) -#else - do i=1,4 - tmp=65536.0d0**(4-i) - iseed_array(i) = dint(seed/tmp) - seed=seed-iseed_array(i)*tmp - enddo - if(me.eq.king) & - write (iout,*) 'MPI: node= ', me, ' iseed(4)= ',& - (iseed_array(i),i=1,4) - write (*,*) 'MPI: node= ',me, ' iseed(4)= ',& - (iseed_array(i),i=1,4) - OKRandom = prng_restart(me,iseed_array) -#endif - if (OKRandom) then -! r1 = prng_next(me) - r1=ran_number(0.0D0,1.0D0) - if(me.eq.king) & - write (iout,*) 'ran_num',r1 - if (r1.lt.0.0d0) OKRandom=.false. - endif - if (.not.OKRandom) then - write (iout,*) 'PRNG IS NOT WORKING!!!' - print *,'PRNG IS NOT WORKING!!!' - if (me.eq.0) then - call flush(iout) - call mpi_abort(mpi_comm_world,error_msg,ierr) - stop - else - write (iout,*) 'too many processors for parallel prng' - write (*,*) 'too many processors for parallel prng' - call flush(iout) - stop - endif - endif - endif -#else - call vrndst(iseed) - write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0) -#endif - return - end subroutine random_init -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module random diff --git a/source/unres/regularize.F90 b/source/unres/regularize.F90 new file mode 100644 index 0000000..8178a4c --- /dev/null +++ b/source/unres/regularize.F90 @@ -0,0 +1,510 @@ + module regularize_ + use names + use io_units + use geometry_data + use energy_data +#if !defined(WHAM_RUN) && !defined(CLUSTER) + use minim_data, only: maxfun,rtolf +#endif + implicit none + contains +#if !defined(WHAM_RUN) && !defined(CLUSTER) +!----------------------------------------------------------------------------- +! regularize.F +!----------------------------------------------------------------------------- + subroutine regularize(ncart,etot,rms,cref0,iretcode) + + use geometry, only: geom_to_var,chainbuild,var_to_geom + use energy, only: etotal,enerprint + use minimm, only: minimize +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.HEADER' +! include 'COMMON.IOUNITS' +! include 'COMMON.MINIM' + integer :: ncart + real(kind=8) :: przes(3),obrot(3,3) + real(kind=8),dimension((nres-1)*(nres-2)/2) :: fhpb0 !(maxdim) (maxdim=(maxres-1)*(maxres-2)/2) + real(kind=8),dimension(6*nres) :: varia !(maxvar)(maxvar=6*maxres) + real(kind=8),dimension(3,ncart) :: cref0 + real(kind=8),dimension(0:n_ene) :: energia + logical :: non_conv + integer :: link_end0,i,maxit_reg,it + real(kind=8) :: etot,rms,rtolf0 + integer :: iretcode,maxit,maxit0,maxfun0,nfun + + link_end0=link_end + do i=1,nhpb + fhpb0(i)=forcon(i) + enddo + maxit_reg=2 + print *,'Enter REGULARIZE: nnt=',nnt,' nct=',nct,' nsup=',nsup,& + ' nstart_seq=',nstart_seq,' nstart_sup',nstart_sup + write (iout,'(/a/)') 'Initial energies:' + call geom_to_var(nvar,varia) + call chainbuild + call etotal(energia) + etot=energia(0) + call enerprint(energia) + call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),& + nsup,przes,obrot,non_conv) + write (iout,'(a,f10.5)') & + 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) + write (*,'(a,f10.5)') & + 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) + maxit0=maxit + maxfun0=maxfun + rtolf0=rtolf + maxit=100 + maxfun=200 + rtolf=1.0D-2 + do it=1,maxit_reg + print *,'Regularization: pass:',it +! Minimize with distance constraints, gradually relieving the weight. + call minimize(etot,varia,iretcode,nfun) + print *,'Etot=',Etot + if (iretcode.eq.11) return + call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),& + nsup,przes,obrot,non_conv) + rms=dsqrt(rms) + write (iout,'(a,i2,a,f10.5,a,1pe14.5,a,i3/)') & + 'Finish pass',it,', RMS deviation:',rms,', energy',etot,& + ' SUMSL convergence',iretcode + do i=nss+1,nhpb + forcon(i)=0.1D0*forcon(i) + enddo + enddo +! Turn off the distance constraints and re-minimize energy. + print *,'Final minimization ... ' + maxit=maxit0 + maxfun=maxfun0 + rtolf=rtolf0 + link_end=min0(link_end,nss) + call minimize(etot,varia,iretcode,nfun) + print *,'Etot=',Etot + call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),nsup,& + przes,obrot,non_conv) + rms=dsqrt(rms) + write (iout,'(a,f10.5,a,1pe14.5,a,i3/)') & + 'Final RMS deviation:',rms,' energy',etot,' SUMSL convergence',& + iretcode + link_end=link_end0 + do i=nss+1,nhpb + forcon(i)=fhpb0(i) + enddo + call var_to_geom(nvar,varia) + call chainbuild + return + end subroutine regularize +#endif +!----------------------------------------------------------------------------- +! fitsq.f +!----------------------------------------------------------------------------- + subroutine fitsq(rms,x,y,nn,t,b,non_conv) + +! implicit real*8 (a-h,o-z) +! include 'COMMON.IOUNITS' +! x and y are the vectors of coordinates (dimensioned (3,n)) of the two +! structures to be superimposed. nn is 3*n, where n is the number of +! points. t and b are respectively the translation vector and the +! rotation matrix that transforms the second set of coordinates to the +! frame of the first set. +! eta = machine-specific variable + integer :: nn,i,n,j,nc + real(kind=8),dimension(3*nn) :: x,y + real(kind=8),dimension(3,3) :: b,q,r,c + real(kind=8),dimension(3) :: t,v,xav,yav,e + logical :: non_conv + +!el local variables + real(kind=8) :: rms,fn,d,sn3 + +! eta = z00100000 +! small=25.0*rmdcon(3) +! small=25.0*eta +! small=25.0*10.e-10 +! the following is a very lenient value for 'small' + real(kind=8) :: small = 0.0001D0 + non_conv=.false. + fn=nn + do 10 i=1,3 + xav(i)=0.0D0 + yav(i)=0.0D0 + do 10 j=1,3 + 10 b(j,i)=0.0D0 + nc=0 +! + do 30 n=1,nn + do 20 i=1,3 +! write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) + xav(i)=xav(i)+x(nc+i)/fn + 20 yav(i)=yav(i)+y(nc+i)/fn + 30 nc=nc+3 +! + do i=1,3 + t(i)=yav(i)-xav(i) + enddo + + rms=0.0d0 + do n=1,nn + do i=1,3 + rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 + enddo + enddo + rms=dabs(rms/fn) + +! write(iout,*)'xav = ',(xav(j),j=1,3) +! write(iout,*)'yav = ',(yav(j),j=1,3) +! write(iout,*)'t = ',(t(j),j=1,3) +! write(iout,*)'rms=',rms + if (rms.lt.small) return + + + nc=0 + rms=0.0D0 + do 50 n=1,nn + do 40 i=1,3 + rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn + do 40 j=1,3 + b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn + 40 c(j,i)=b(j,i) + 50 nc=nc+3 + call sivade(b,q,r,d,non_conv) + sn3=dsign(1.0d0,d) + do 120 i=1,3 + do 120 j=1,3 + 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) + call mvvad(b,xav,yav,t) + do 130 i=1,3 + do 130 j=1,3 + rms=rms+2.0*c(j,i)*b(j,i) + 130 b(j,i)=-b(j,i) + if (dabs(rms).gt.small) go to 140 +! write (6,301) + return + 140 if (rms.gt.0.0d0) go to 150 +! write (iout,303) rms + rms=0.0d0 +! stop +! 150 write (iout,302) dsqrt(rms) + 150 continue + return + 301 format (5x,'rms deviation negligible') + 302 format (5x,'rms deviation ',f14.6) + 303 format (//,5x,'negative ms deviation - ',f14.6) + end subroutine fitsq +!----------------------------------------------------------------------------- + subroutine sivade(x,q,r,dt,non_conv) + +! implicit real*8(a-h,o-z) +! computes q,e and r such that q(t)xr = diag(e) + real(kind=8),dimension(3,3) :: x,q,r + real(kind=8),dimension(3) :: e + real(kind=8),dimension(3,3) :: h,p,u + real(kind=8),dimension(3) :: d + logical :: non_conv + +!el local variables + integer :: nit,i,j,n,np,nq,npq,n0,nn + real(kind=8) :: dt,small,xnrm,xmax,a,den,s,b,c,dd,xn2,y,z,rt,t,v,w + +! eta = z00100000 +! write (2,*) "SIVADE" + nit = 0 + small=25.0*10.d-10 +! small=25.0*eta +! small=2.0*rmdcon(3) + xnrm=0.0d0 + do 20 i=1,3 + do 10 j=1,3 + xnrm=xnrm+x(j,i)*x(j,i) + u(j,i)=0.0d0 + r(j,i)=0.0d0 + 10 h(j,i)=0.0d0 + u(i,i)=1.0 + 20 r(i,i)=1.0 + xnrm=dsqrt(xnrm) + do 110 n=1,2 + xmax=0.0d0 + do 30 j=n,3 + 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) + a=0.0d0 + do 40 j=n,3 + h(j,n)=x(j,n)/xmax + 40 a=a+h(j,n)*h(j,n) + a=dsqrt(a) + den=a*(a+dabs(h(n,n))) + d(n)=1.0/den + h(n,n)=h(n,n)+dsign(a,h(n,n)) + do 70 i=n,3 + s=0.0d0 + do 50 j=n,3 + 50 s=s+h(j,n)*x(j,i) + s=d(n)*s + do 60 j=n,3 + 60 x(j,i)=x(j,i)-s*h(j,n) + 70 continue + if (n.gt.1) go to 110 + xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) + h(2,3)=x(1,2)/xmax + h(3,3)=x(1,3)/xmax + a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) + den=a*(a+dabs(h(2,3))) + d(3)=1.0/den + h(2,3)=h(2,3)+sign(a,h(2,3)) + do 100 i=1,3 + s=0.0d0 + do 80 j=2,3 + 80 s=s+h(j,3)*x(i,j) + s=d(3)*s + do 90 j=2,3 + 90 x(i,j)=x(i,j)-s*h(j,3) + 100 continue + 110 continue + do 130 i=1,3 + do 120 j=1,3 + 120 p(j,i)=-d(1)*h(j,1)*h(i,1) + 130 p(i,i)=1.0+p(i,i) + do 140 i=2,3 + do 140 j=2,3 + u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) + 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) + call mmmul(p,u,q) + 150 np=1 + nq=1 + nit=nit+1 +! write (2,*) "nit",nit," e",(x(i,i),i=1,3) + if (nit.gt.10000) then + print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' + non_conv=.true. + return + endif + if (dabs(x(2,3)).gt.small*(dabs(x(2,2))+abs(x(3,3)))) go to 160 + x(2,3)=0.0d0 + nq=nq+1 + 160 if (dabs(x(1,2)).gt.small*(dabs(x(1,1))+dabs(x(2,2)))) go to 180 + x(1,2)=0.0d0 + if (x(2,3).ne.0.0d0) go to 170 + nq=nq+1 + go to 180 + 170 np=np+1 + 180 if (nq.eq.3) go to 310 + npq=4-np-nq +! write (2,*) "np",np," npq",npq + if (np.gt.npq) go to 230 + n0=0 + do 220 n=np,npq + nn=n+np-1 +! write (2,*) "nn",nn + if (dabs(x(nn,nn)).gt.small*xnrm) go to 220 + x(nn,nn)=0.0d0 + if (x(nn,nn+1).eq.0.0d0) go to 220 + n0=n0+1 +! write (2,*) "nn",nn + go to (190,210,220),nn + 190 do 200 j=2,3 + 200 call givns(x,q,1,j) + go to 220 + 210 call givns(x,q,2,3) + 220 continue +! write (2,*) "nn",nn," np",np," nq",nq," n0",n0 +! write (2,*) "x",(x(i,i),i=1,3) + if (n0.ne.0) go to 150 + 230 nn=3-nq + a=x(nn,nn)*x(nn,nn) + if (nn.gt.1) a=a+x(nn-1,nn)*x(nn-1,nn) + b=x(nn+1,nn+1)*x(nn+1,nn+1)+x(nn,nn+1)*x(nn,nn+1) + c=x(nn,nn)*x(nn,nn+1) + dd=0.5*(a-b) + xn2=c*c + rt=b-xn2/(dd+sign(dsqrt(dd*dd+xn2),dd)) + y=x(np,np)*x(np,np)-rt + z=x(np,np)*x(np,np+1) + do 300 n=np,nn +! write (2,*) "n",n," a",a," b",b," c",c," y",y," z",z + if (dabs(y).lt.dabs(z)) go to 240 + t=z/y + c=1.0/dsqrt(1.0d0+t*t) + s=c*t + go to 250 + 240 t=y/z + s=1.0/dsqrt(1.0d0+t*t) + c=s*t + 250 do 260 j=1,3 + v=x(j,n) + w=x(j,n+1) + x(j,n)=c*v+s*w + x(j,n+1)=-s*v+c*w + a=r(j,n) + b=r(j,n+1) + r(j,n)=c*a+s*b + 260 r(j,n+1)=-s*a+c*b + y=x(n,n) + z=x(n+1,n) + if (dabs(y).lt.dabs(z)) go to 270 + t=z/y + c=1.0/dsqrt(1.0+t*t) + s=c*t + go to 280 + 270 t=y/z + s=1.0/dsqrt(1.0+t*t) + c=s*t + 280 do 290 j=1,3 + v=x(n,j) + w=x(n+1,j) + a=q(j,n) + b=q(j,n+1) + x(n,j)=c*v+s*w + x(n+1,j)=-s*v+c*w + q(j,n)=c*a+s*b + 290 q(j,n+1)=-s*a+c*b + if (n.ge.nn) go to 300 + y=x(n,n+1) + z=x(n,n+2) + 300 continue + go to 150 + 310 do 320 i=1,3 + 320 e(i)=x(i,i) + nit=0 + 330 n0=0 + nit=nit+1 + if (nit.gt.10000) then + print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' + non_conv=.true. + return + endif +! write (2,*) "e",(e(i),i=1,3) + do 360 i=1,3 + if (e(i).ge.0.0d0) go to 350 + e(i)=-e(i) + do 340 j=1,3 + 340 q(j,i)=-q(j,i) + 350 if (i.eq.1) go to 360 + if (dabs(e(i)).lt.dabs(e(i-1))) go to 360 + call switch(i,1,q,r,e) + n0=n0+1 + 360 continue + if (n0.ne.0) go to 330 +! write (2,*) "e",(e(i),i=1,3) + if (dabs(e(3)).gt.small*xnrm) go to 370 + e(3)=0.0d0 + if (dabs(e(2)).gt.small*xnrm) go to 370 + e(2)=0.0d0 + 370 dt=det(q(1,1),q(1,2),q(1,3))*det(r(1,1),r(1,2),r(1,3)) +! write (2,*) "nit",nit +! write (2,501) (e(i),i=1,3) + return + 501 format (/,5x,'singular values - ',3e15.5) + end subroutine sivade +!----------------------------------------------------------------------------- + subroutine givns(a,b,m,n) + +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3,3) :: a,b + integer :: m,n,j + real(kind=8) :: t,c,s,v,w,x,y + + if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 + t=a(n,n)/a(m,n) + s=1.0/dsqrt(1.0+t*t) + c=s*t + go to 20 + 10 t=a(m,n)/a(n,n) + c=1.0/dsqrt(1.0+t*t) + s=c*t + 20 do 30 j=1,3 + v=a(m,j) + w=a(n,j) + x=b(j,m) + y=b(j,n) + a(m,j)=c*v-s*w + a(n,j)=s*v+c*w + b(j,m)=c*x-s*y + 30 b(j,n)=s*x+c*y + return + end subroutine givns +!----------------------------------------------------------------------------- + subroutine switch(n,m,u,v,d) + +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3,3) :: u,v + real(kind=8),dimension(3) :: d + integer :: n,m,i + real(kind=8) :: tem + do 10 i=1,3 + tem=u(i,n) + u(i,n)=u(i,n-1) + u(i,n-1)=tem + if (m.eq.0) go to 10 + tem=v(i,n) + v(i,n)=v(i,n-1) + v(i,n-1)=tem + 10 continue + tem=d(n) + d(n)=d(n-1) + d(n-1)=tem + return + end subroutine switch +!----------------------------------------------------------------------------- + subroutine mvvad(b,xav,yav,t) + +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3,3) :: b + real(kind=8),dimension(3) :: xav,yav,t + integer :: i,j +! dimension a(3,3),b(3),c(3),d(3) +! do 10 j=1,3 +! d(j)=c(j) +! do 10 i=1,3 +! 10 d(j)=d(j)+a(j,i)*b(i) + do 10 j=1,3 + t(j)=yav(j) + do 10 i=1,3 + 10 t(j)=t(j)+b(j,i)*xav(i) + return + end subroutine mvvad +!----------------------------------------------------------------------------- + real(kind=8) function det(a,b,c) +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3) :: a,b,c + det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) & + +a(3)*(b(1)*c(2)-b(2)*c(1)) + return + end function det +!----------------------------------------------------------------------------- + subroutine mmmul(a,b,c) + +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3,3) :: a,b,c + integer :: i,j,k + do 10 i=1,3 + do 10 j=1,3 + c(i,j)=0.0d0 + do 10 k=1,3 + 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) + return + end subroutine mmmul +#if !defined(WHAM_RUN) || !defined(CLUSTER) +!----------------------------------------------------------------------------- + subroutine matvec(uvec,tmat,pvec,nback) + +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3,3) :: tmat + real(kind=8),dimension(3,nback) :: uvec,pvec + integer :: nback,i,j,k +! + do 2 j=1,nback + do 1 i=1,3 + uvec(i,j) = 0.0d0 + do 1 k=1,3 + 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) + 2 continue + return + end subroutine matvec +!----------------------------------------------------------------------------- +#endif +!----------------------------------------------------------------------------- + end module regularize_ diff --git a/source/unres/regularize.f90 b/source/unres/regularize.f90 deleted file mode 100644 index 0eb81e5..0000000 --- a/source/unres/regularize.f90 +++ /dev/null @@ -1,510 +0,0 @@ - module regularize_ - use names - use io_units - use geometry_data - use energy_data -#if .not. defined WHAM_RUN && .not. defined CLUSTER - use minim_data, only: maxfun,rtolf -#endif - implicit none - contains -#if .not. defined WHAM_RUN && .not. defined CLUSTER -!----------------------------------------------------------------------------- -! regularize.F -!----------------------------------------------------------------------------- - subroutine regularize(ncart,etot,rms,cref0,iretcode) - - use geometry, only: geom_to_var,chainbuild,var_to_geom - use energy, only: etotal,enerprint - use minimm, only: minimize -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.HEADER' -! include 'COMMON.IOUNITS' -! include 'COMMON.MINIM' - integer :: ncart - real(kind=8) :: przes(3),obrot(3,3) - real(kind=8),dimension((nres-1)*(nres-2)/2) :: fhpb0 !(maxdim) (maxdim=(maxres-1)*(maxres-2)/2) - real(kind=8),dimension(6*nres) :: varia !(maxvar)(maxvar=6*maxres) - real(kind=8),dimension(3,ncart) :: cref0 - real(kind=8),dimension(0:n_ene) :: energia - logical :: non_conv - integer :: link_end0,i,maxit_reg,it - real(kind=8) :: etot,rms,rtolf0 - integer :: iretcode,maxit,maxit0,maxfun0,nfun - - link_end0=link_end - do i=1,nhpb - fhpb0(i)=forcon(i) - enddo - maxit_reg=2 - print *,'Enter REGULARIZE: nnt=',nnt,' nct=',nct,' nsup=',nsup,& - ' nstart_seq=',nstart_seq,' nstart_sup',nstart_sup - write (iout,'(/a/)') 'Initial energies:' - call geom_to_var(nvar,varia) - call chainbuild - call etotal(energia) - etot=energia(0) - call enerprint(energia) - call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),& - nsup,przes,obrot,non_conv) - write (iout,'(a,f10.5)') & - 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) - write (*,'(a,f10.5)') & - 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) - maxit0=maxit - maxfun0=maxfun - rtolf0=rtolf - maxit=100 - maxfun=200 - rtolf=1.0D-2 - do it=1,maxit_reg - print *,'Regularization: pass:',it -! Minimize with distance constraints, gradually relieving the weight. - call minimize(etot,varia,iretcode,nfun) - print *,'Etot=',Etot - if (iretcode.eq.11) return - call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),& - nsup,przes,obrot,non_conv) - rms=dsqrt(rms) - write (iout,'(a,i2,a,f10.5,a,1pe14.5,a,i3/)') & - 'Finish pass',it,', RMS deviation:',rms,', energy',etot,& - ' SUMSL convergence',iretcode - do i=nss+1,nhpb - forcon(i)=0.1D0*forcon(i) - enddo - enddo -! Turn off the distance constraints and re-minimize energy. - print *,'Final minimization ... ' - maxit=maxit0 - maxfun=maxfun0 - rtolf=rtolf0 - link_end=min0(link_end,nss) - call minimize(etot,varia,iretcode,nfun) - print *,'Etot=',Etot - call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),nsup,& - przes,obrot,non_conv) - rms=dsqrt(rms) - write (iout,'(a,f10.5,a,1pe14.5,a,i3/)') & - 'Final RMS deviation:',rms,' energy',etot,' SUMSL convergence',& - iretcode - link_end=link_end0 - do i=nss+1,nhpb - forcon(i)=fhpb0(i) - enddo - call var_to_geom(nvar,varia) - call chainbuild - return - end subroutine regularize -#endif -!----------------------------------------------------------------------------- -! fitsq.f -!----------------------------------------------------------------------------- - subroutine fitsq(rms,x,y,nn,t,b,non_conv) - -! implicit real*8 (a-h,o-z) -! include 'COMMON.IOUNITS' -! x and y are the vectors of coordinates (dimensioned (3,n)) of the two -! structures to be superimposed. nn is 3*n, where n is the number of -! points. t and b are respectively the translation vector and the -! rotation matrix that transforms the second set of coordinates to the -! frame of the first set. -! eta = machine-specific variable - integer :: nn,i,n,j,nc - real(kind=8),dimension(3*nn) :: x,y - real(kind=8),dimension(3,3) :: b,q,r,c - real(kind=8),dimension(3) :: t,v,xav,yav,e - logical :: non_conv - -!el local variables - real(kind=8) :: rms,fn,d,sn3 - -! eta = z00100000 -! small=25.0*rmdcon(3) -! small=25.0*eta -! small=25.0*10.e-10 -! the following is a very lenient value for 'small' - real(kind=8) :: small = 0.0001D0 - non_conv=.false. - fn=nn - do 10 i=1,3 - xav(i)=0.0D0 - yav(i)=0.0D0 - do 10 j=1,3 - 10 b(j,i)=0.0D0 - nc=0 -! - do 30 n=1,nn - do 20 i=1,3 -! write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) - xav(i)=xav(i)+x(nc+i)/fn - 20 yav(i)=yav(i)+y(nc+i)/fn - 30 nc=nc+3 -! - do i=1,3 - t(i)=yav(i)-xav(i) - enddo - - rms=0.0d0 - do n=1,nn - do i=1,3 - rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 - enddo - enddo - rms=dabs(rms/fn) - -! write(iout,*)'xav = ',(xav(j),j=1,3) -! write(iout,*)'yav = ',(yav(j),j=1,3) -! write(iout,*)'t = ',(t(j),j=1,3) -! write(iout,*)'rms=',rms - if (rms.lt.small) return - - - nc=0 - rms=0.0D0 - do 50 n=1,nn - do 40 i=1,3 - rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn - do 40 j=1,3 - b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn - 40 c(j,i)=b(j,i) - 50 nc=nc+3 - call sivade(b,q,r,d,non_conv) - sn3=dsign(1.0d0,d) - do 120 i=1,3 - do 120 j=1,3 - 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) - call mvvad(b,xav,yav,t) - do 130 i=1,3 - do 130 j=1,3 - rms=rms+2.0*c(j,i)*b(j,i) - 130 b(j,i)=-b(j,i) - if (dabs(rms).gt.small) go to 140 -! write (6,301) - return - 140 if (rms.gt.0.0d0) go to 150 -! write (iout,303) rms - rms=0.0d0 -! stop -! 150 write (iout,302) dsqrt(rms) - 150 continue - return - 301 format (5x,'rms deviation negligible') - 302 format (5x,'rms deviation ',f14.6) - 303 format (//,5x,'negative ms deviation - ',f14.6) - end subroutine fitsq -!----------------------------------------------------------------------------- - subroutine sivade(x,q,r,dt,non_conv) - -! implicit real*8(a-h,o-z) -! computes q,e and r such that q(t)xr = diag(e) - real(kind=8),dimension(3,3) :: x,q,r - real(kind=8),dimension(3) :: e - real(kind=8),dimension(3,3) :: h,p,u - real(kind=8),dimension(3) :: d - logical :: non_conv - -!el local variables - integer :: nit,i,j,n,np,nq,npq,n0,nn - real(kind=8) :: dt,small,xnrm,xmax,a,den,s,b,c,dd,xn2,y,z,rt,t,v,w - -! eta = z00100000 -! write (2,*) "SIVADE" - nit = 0 - small=25.0*10.d-10 -! small=25.0*eta -! small=2.0*rmdcon(3) - xnrm=0.0d0 - do 20 i=1,3 - do 10 j=1,3 - xnrm=xnrm+x(j,i)*x(j,i) - u(j,i)=0.0d0 - r(j,i)=0.0d0 - 10 h(j,i)=0.0d0 - u(i,i)=1.0 - 20 r(i,i)=1.0 - xnrm=dsqrt(xnrm) - do 110 n=1,2 - xmax=0.0d0 - do 30 j=n,3 - 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) - a=0.0d0 - do 40 j=n,3 - h(j,n)=x(j,n)/xmax - 40 a=a+h(j,n)*h(j,n) - a=dsqrt(a) - den=a*(a+dabs(h(n,n))) - d(n)=1.0/den - h(n,n)=h(n,n)+dsign(a,h(n,n)) - do 70 i=n,3 - s=0.0d0 - do 50 j=n,3 - 50 s=s+h(j,n)*x(j,i) - s=d(n)*s - do 60 j=n,3 - 60 x(j,i)=x(j,i)-s*h(j,n) - 70 continue - if (n.gt.1) go to 110 - xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) - h(2,3)=x(1,2)/xmax - h(3,3)=x(1,3)/xmax - a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) - den=a*(a+dabs(h(2,3))) - d(3)=1.0/den - h(2,3)=h(2,3)+sign(a,h(2,3)) - do 100 i=1,3 - s=0.0d0 - do 80 j=2,3 - 80 s=s+h(j,3)*x(i,j) - s=d(3)*s - do 90 j=2,3 - 90 x(i,j)=x(i,j)-s*h(j,3) - 100 continue - 110 continue - do 130 i=1,3 - do 120 j=1,3 - 120 p(j,i)=-d(1)*h(j,1)*h(i,1) - 130 p(i,i)=1.0+p(i,i) - do 140 i=2,3 - do 140 j=2,3 - u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) - 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) - call mmmul(p,u,q) - 150 np=1 - nq=1 - nit=nit+1 -! write (2,*) "nit",nit," e",(x(i,i),i=1,3) - if (nit.gt.10000) then - print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' - non_conv=.true. - return - endif - if (dabs(x(2,3)).gt.small*(dabs(x(2,2))+abs(x(3,3)))) go to 160 - x(2,3)=0.0d0 - nq=nq+1 - 160 if (dabs(x(1,2)).gt.small*(dabs(x(1,1))+dabs(x(2,2)))) go to 180 - x(1,2)=0.0d0 - if (x(2,3).ne.0.0d0) go to 170 - nq=nq+1 - go to 180 - 170 np=np+1 - 180 if (nq.eq.3) go to 310 - npq=4-np-nq -! write (2,*) "np",np," npq",npq - if (np.gt.npq) go to 230 - n0=0 - do 220 n=np,npq - nn=n+np-1 -! write (2,*) "nn",nn - if (dabs(x(nn,nn)).gt.small*xnrm) go to 220 - x(nn,nn)=0.0d0 - if (x(nn,nn+1).eq.0.0d0) go to 220 - n0=n0+1 -! write (2,*) "nn",nn - go to (190,210,220),nn - 190 do 200 j=2,3 - 200 call givns(x,q,1,j) - go to 220 - 210 call givns(x,q,2,3) - 220 continue -! write (2,*) "nn",nn," np",np," nq",nq," n0",n0 -! write (2,*) "x",(x(i,i),i=1,3) - if (n0.ne.0) go to 150 - 230 nn=3-nq - a=x(nn,nn)*x(nn,nn) - if (nn.gt.1) a=a+x(nn-1,nn)*x(nn-1,nn) - b=x(nn+1,nn+1)*x(nn+1,nn+1)+x(nn,nn+1)*x(nn,nn+1) - c=x(nn,nn)*x(nn,nn+1) - dd=0.5*(a-b) - xn2=c*c - rt=b-xn2/(dd+sign(dsqrt(dd*dd+xn2),dd)) - y=x(np,np)*x(np,np)-rt - z=x(np,np)*x(np,np+1) - do 300 n=np,nn -! write (2,*) "n",n," a",a," b",b," c",c," y",y," z",z - if (dabs(y).lt.dabs(z)) go to 240 - t=z/y - c=1.0/dsqrt(1.0d0+t*t) - s=c*t - go to 250 - 240 t=y/z - s=1.0/dsqrt(1.0d0+t*t) - c=s*t - 250 do 260 j=1,3 - v=x(j,n) - w=x(j,n+1) - x(j,n)=c*v+s*w - x(j,n+1)=-s*v+c*w - a=r(j,n) - b=r(j,n+1) - r(j,n)=c*a+s*b - 260 r(j,n+1)=-s*a+c*b - y=x(n,n) - z=x(n+1,n) - if (dabs(y).lt.dabs(z)) go to 270 - t=z/y - c=1.0/dsqrt(1.0+t*t) - s=c*t - go to 280 - 270 t=y/z - s=1.0/dsqrt(1.0+t*t) - c=s*t - 280 do 290 j=1,3 - v=x(n,j) - w=x(n+1,j) - a=q(j,n) - b=q(j,n+1) - x(n,j)=c*v+s*w - x(n+1,j)=-s*v+c*w - q(j,n)=c*a+s*b - 290 q(j,n+1)=-s*a+c*b - if (n.ge.nn) go to 300 - y=x(n,n+1) - z=x(n,n+2) - 300 continue - go to 150 - 310 do 320 i=1,3 - 320 e(i)=x(i,i) - nit=0 - 330 n0=0 - nit=nit+1 - if (nit.gt.10000) then - print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' - non_conv=.true. - return - endif -! write (2,*) "e",(e(i),i=1,3) - do 360 i=1,3 - if (e(i).ge.0.0d0) go to 350 - e(i)=-e(i) - do 340 j=1,3 - 340 q(j,i)=-q(j,i) - 350 if (i.eq.1) go to 360 - if (dabs(e(i)).lt.dabs(e(i-1))) go to 360 - call switch(i,1,q,r,e) - n0=n0+1 - 360 continue - if (n0.ne.0) go to 330 -! write (2,*) "e",(e(i),i=1,3) - if (dabs(e(3)).gt.small*xnrm) go to 370 - e(3)=0.0d0 - if (dabs(e(2)).gt.small*xnrm) go to 370 - e(2)=0.0d0 - 370 dt=det(q(1,1),q(1,2),q(1,3))*det(r(1,1),r(1,2),r(1,3)) -! write (2,*) "nit",nit -! write (2,501) (e(i),i=1,3) - return - 501 format (/,5x,'singular values - ',3e15.5) - end subroutine sivade -!----------------------------------------------------------------------------- - subroutine givns(a,b,m,n) - -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3,3) :: a,b - integer :: m,n,j - real(kind=8) :: t,c,s,v,w,x,y - - if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 - t=a(n,n)/a(m,n) - s=1.0/dsqrt(1.0+t*t) - c=s*t - go to 20 - 10 t=a(m,n)/a(n,n) - c=1.0/dsqrt(1.0+t*t) - s=c*t - 20 do 30 j=1,3 - v=a(m,j) - w=a(n,j) - x=b(j,m) - y=b(j,n) - a(m,j)=c*v-s*w - a(n,j)=s*v+c*w - b(j,m)=c*x-s*y - 30 b(j,n)=s*x+c*y - return - end subroutine givns -!----------------------------------------------------------------------------- - subroutine switch(n,m,u,v,d) - -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3,3) :: u,v - real(kind=8),dimension(3) :: d - integer :: n,m,i - real(kind=8) :: tem - do 10 i=1,3 - tem=u(i,n) - u(i,n)=u(i,n-1) - u(i,n-1)=tem - if (m.eq.0) go to 10 - tem=v(i,n) - v(i,n)=v(i,n-1) - v(i,n-1)=tem - 10 continue - tem=d(n) - d(n)=d(n-1) - d(n-1)=tem - return - end subroutine switch -!----------------------------------------------------------------------------- - subroutine mvvad(b,xav,yav,t) - -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3,3) :: b - real(kind=8),dimension(3) :: xav,yav,t - integer :: i,j -! dimension a(3,3),b(3),c(3),d(3) -! do 10 j=1,3 -! d(j)=c(j) -! do 10 i=1,3 -! 10 d(j)=d(j)+a(j,i)*b(i) - do 10 j=1,3 - t(j)=yav(j) - do 10 i=1,3 - 10 t(j)=t(j)+b(j,i)*xav(i) - return - end subroutine mvvad -!----------------------------------------------------------------------------- - real(kind=8) function det(a,b,c) -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3) :: a,b,c - det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) & - +a(3)*(b(1)*c(2)-b(2)*c(1)) - return - end function det -!----------------------------------------------------------------------------- - subroutine mmmul(a,b,c) - -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3,3) :: a,b,c - integer :: i,j,k - do 10 i=1,3 - do 10 j=1,3 - c(i,j)=0.0d0 - do 10 k=1,3 - 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) - return - end subroutine mmmul -#if .not. defined WHAM_RUN || .not. defined CLUSTER -!----------------------------------------------------------------------------- - subroutine matvec(uvec,tmat,pvec,nback) - -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3,3) :: tmat - real(kind=8),dimension(3,nback) :: uvec,pvec - integer :: nback,i,j,k -! - do 2 j=1,nback - do 1 i=1,3 - uvec(i,j) = 0.0d0 - do 1 k=1,3 - 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) - 2 continue - return - end subroutine matvec -!----------------------------------------------------------------------------- -#endif -!----------------------------------------------------------------------------- - end module regularize_ diff --git a/source/unres/unres.F90 b/source/unres/unres.F90 new file mode 100644 index 0000000..89feccc --- /dev/null +++ b/source/unres/unres.F90 @@ -0,0 +1,1055 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! U N R E S ! +! ! +! Program to carry out conformational search of proteins in an united-residue ! +! approximation. ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + program unres + + use io_units + use control_data + use control, only:tcpu + use io_base, only:ilen + use geometry, only:chainbuild + use control, only:dajczas + use check_bond_ + use energy + use compare, only: test + use map_ + use MDyn + use MPI_ + use io, only:readrtns + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + use MPI_data ! include 'COMMON.SETUP' + implicit none + include 'mpif.h' + integer :: ierr +#else + use MPI_data, only: me,king + implicit none +#endif +! include 'COMMON.TIME1' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.GEO' +! include 'COMMON.HEADER' +! include 'COMMON.CONTROL' +! include 'COMMON.CONTACTS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.REMD' +! include 'COMMON.MD' +! include 'COMMON.SBRIDGE' + + real(kind=8) :: hrtime,mintime,sectime + character(len=64) :: text_mode_calc(-2:14) + text_mode_calc(-2) = 'test' + text_mode_calc(-1) = 'cos' + text_mode_calc(0) = 'Energy evaluation or minimization' + text_mode_calc(1) = 'Regularization of PDB structure' + text_mode_calc(2) = 'Threading of a sequence on PDB structures' + text_mode_calc(3) = 'Monte Carlo (with minimization) ' + text_mode_calc(4) = 'Energy minimization of multiple conformations' + text_mode_calc(5) = 'Checking energy gradient' + text_mode_calc(6) = 'Entropic sampling Monte Carlo (with minimization)' + text_mode_calc(7) = 'Energy map' + text_mode_calc(8) = 'CSA calculations' + text_mode_calc(9) = 'Not used 9' + text_mode_calc(10) = 'Not used 10' + text_mode_calc(11) = 'Soft regularization of PDB structure' + text_mode_calc(12) = 'Mesoscopic molecular dynamics (MD) ' + text_mode_calc(13) = 'Not used 13' + text_mode_calc(14) = 'Replica exchange molecular dynamics (REMD)' +! external ilen +! call memmon_print_usage() + + call init_task + if (me.eq.king) & + write(iout,*)'### LAST MODIFIED 09/03/15 15:32PM by EL' + if (me.eq.king) call cinfo +! Read force field parameters and job setup data + call readrtns + call flush(iout) +! + if (me.eq.king .or. .not. out1file) then + write (iout,'(2a/)') & + text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))), & + ' calculation.' + if (minim) write (iout,'(a)') & + 'Conformations will be energy-minimized.' + write (iout,'(80(1h*)/)') + endif + call flush(iout) +! + if (modecalc.eq.-2) then + call test + stop + else if (modecalc.eq.-1) then + write(iout,*) "call check_sc_map next" + call check_bond + stop + endif +!elwrite(iout,*)"!!!!!!!!!!!!!!!!! in unres" + +#ifdef MPI + if (fg_rank.gt.0) then +! Fine-grain slaves just do energy and gradient components. + call ergastulum ! slave workhouse in Latin + else +#endif + if (modecalc.eq.0) then +!write(iout,*)"!!!!!!!!!!!!!!!!! in unres" + + call exec_eeval_or_minim +!write(iout,*)"!!!!!!!!!!!!!!!!! in unres" + + else if (modecalc.eq.1) then + call exec_regularize + else if (modecalc.eq.2) then + call exec_thread + else if (modecalc.eq.3 .or. modecalc .eq.6) then + call exec_MC + else if (modecalc.eq.4) then + call exec_mult_eeval_or_minim + else if (modecalc.eq.5) then + call exec_checkgrad +!write(iout,*) "check grad dwa razy" +!el call exec_checkgrad + else if (ModeCalc.eq.7) then + call exec_map + else if (ModeCalc.eq.8) then + call exec_CSA + else if (modecalc.eq.11) then + call exec_softreg + else if (modecalc.eq.12) then + call exec_MD + else if (modecalc.eq.14) then + call exec_MREMD + else + write (iout,'(a)') 'This calculation type is not supported',& + ModeCalc + endif +!elwrite(iout,*)"!!!!!!!!!!!!!!!!!" + +#ifdef MPI + endif +! Finish task. + if (fg_rank.eq.0) call finish_task +! call memmon_print_usage() +#ifdef TIMING + call print_detailed_timing +#endif + call MPI_Finalize(ierr) + stop 'Bye Bye...' +#else + call dajczas(tcpu(),hrtime,mintime,sectime) + stop '********** Program terminated normally.' +#endif + + end program !UNRES +!----------------------------------------------------------------------------- +! +!----------------------------------------------------------------------------- + subroutine exec_MD + use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL' + use geometry, only:chainbuild + use MDyn + use io_units !include 'COMMON.IOUNITS' +! use io_common + implicit none +! include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + call alloc_MD_arrays + if (me.eq.king .or. .not. out1file) & + write (iout,*) "Calling chainbuild" + call chainbuild + call MD + return + end subroutine exec_MD +!--------------------------------------------------------------------------- + subroutine exec_MREMD + use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL' + use io_units !include 'COMMON.IOUNITS' +! use io_common + use REMD_data !include 'COMMON.REMD' + use geometry, only:chainbuild + use MREMDyn + + implicit none +! include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + + integer :: i + call alloc_MD_arrays + call alloc_MREMD_arrays + + if (me.eq.king .or. .not. out1file) & + write (iout,*) "Calling chainbuild" + call chainbuild + if (me.eq.king .or. .not. out1file) & + write (iout,*) "Calling REMD" + if (remd_mlist) then + call MREMD + else + do i=1,nrep + remd_m(i)=1 + enddo + call MREMD + endif + return + end subroutine exec_MREMD +!----------------------------------------------------------------------------- + subroutine exec_eeval_or_minim + use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' + use io_units !include 'COMMON.IOUNITS' + use names +! use energy !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' + use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' +! use REMD !include 'COMMON.REMD' +! use MD !include 'COMMON.MD' + + use energy_data + + use io_base + use geometry, only:chainbuild + use energy + use compare, only:alloc_compare_arrays,hairpin,secondary2,rms_nac_nnc + use minimm, only:minimize,minim_dc,sc_move + use compare_data !el + use comm_srutu + implicit none +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + integer :: i +!el common /srutu/ icall + real(kind=8) :: energy_(0:n_ene) + real(kind=8) :: energy_long(0:n_ene),energy_short(0:n_ene) + real(kind=8) :: varia(6*nres) !(maxvar) (maxvar=6*maxres) + real(kind=8) :: time00, evals, etota, etot, time_ene, time1 + integer :: nharp,nft_sc,iretcode,nfun + integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) + logical :: fail + real(kind=8) :: rms,frac,frac_nn,co + + integer :: j,k + call alloc_compare_arrays + if (indpdb.eq.0) call chainbuild +#ifdef MPI + time00=MPI_Wtime() +#endif + call chainbuild_cart +! write(iout,*)"in exec_eeval or minimim",split_ene +! do j=1,2*nres+2 +! write(iout,*)"cccccc",j,(c(i,j),i=1,3) +! write(iout,*)"dcccccc",j,(dc(i,j),i=1,3) +! enddo + if (split_ene) then +! write(iout,*)"in exec_eeval or minimim" + + print *,"Processor",myrank," after chainbuild" + icall=1 +!elwrite(iout,*)"in exec_eeval or minimim" + + call etotal_long(energy_long) + write (iout,*) "Printing long range energy" + call enerprint(energy_long) +!elwrite(iout,*)"in exec_eeval or minimim" + + call etotal_short(energy_short) + write (iout,*) "Printing short range energy" + call enerprint(energy_short) + do i=0,n_ene + energy_(i)=energy_long(i)+energy_short(i) + write (iout,*) i,energy_long(i),energy_short(i),energy_(i) + enddo + write (iout,*) "Printing long+short range energy" + call enerprint(energy_) + endif + + call etotal(energy_) +!elwrite(iout,*)"after etotal in exec_eev" +#ifdef MPI + time_ene=MPI_Wtime()-time00 +#endif + write (iout,*) "Time for energy evaluation",time_ene + print *,"after etotal" + etota = energy_(0) + etot = etota + call enerprint(energy_) +!write(iout,*)"after enerprint" + call hairpin(.true.,nharp,iharp) +!write(iout,*) "after hairpin"!,hfrag(1,1) + call secondary2(.true.) +!write(iout,*) "after secondary2" + if (minim) then +!rc overlap test +!elwrite(iout,*) "after secondary2 minim",minim + if (overlapsc) then + print *, 'Calling OVERLAP_SC' +!write(iout,*) 'Calling OVERLAP_SC' + call overlap_sc(fail) +!write(iout,*) 'after Calling OVERLAP_SC' + endif + + if (searchsc) then + call sc_move(2,nres-1,10,1d10,nft_sc,etot) + print *,'SC_move',nft_sc,etot + write(iout,*) 'SC_move',nft_sc,etot + endif + + if (dccart) then +!write(iout,*) 'CART calling minim_dc', nvar + print *, 'Calling MINIM_DC' +#ifdef MPI + time1=MPI_WTIME() +#endif +! call check_ecartint !el + call minim_dc(etot,iretcode,nfun) +! call check_ecartint !el + else +!write(iout,*) "indpdb",indpdb + if (indpdb.ne.0) then +!write(iout,*) 'if indpdb', indpdb + call bond_regular + call chainbuild + endif + call geom_to_var(nvar,varia) +!write(iout,*) 'po geom to var; calling minimize', nvar + print *,'Calling MINIMIZE.' +#ifdef MPI + time1=MPI_WTIME() +#endif +! call check_eint +! call exec_checkgrad !el + call minimize(etot,varia,iretcode,nfun) +! call check_eint +! call exec_checkgrad !el + endif + print *,'SUMSL return code is',iretcode,' eval ',nfun +#ifdef MPI + evals=nfun/(MPI_WTIME()-time1) +#endif + print *,'# eval/s',evals + print *,'refstr=',refstr + call hairpin(.true.,nharp,iharp) + call secondary2(.true.) + call etotal(energy_) + etot = energy_(0) + call enerprint(energy_) + + call intout + call briefout(0,etot) + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (iout,'(a,i3)') 'SUMSL return code:',iretcode + write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 + write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals + else +!elwrite(iout,*) "after secondary2 minim",minim + print *,'refstr=',refstr + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) +!elwrite(iout,*) "rms_nac" +!elwrite(iout,*) "before briefout" + call briefout(0,etot) +!elwrite(iout,*) "after briefout" + endif + if (outpdb) call pdbout(etot,titel(:32),ipdb) + if (outmol2) call mol2out(etot,titel(:32)) +!elwrite(iout,*) "after exec_eeval_or_minim" + return + end subroutine exec_eeval_or_minim +!----------------------------------------------------------------------------- + subroutine exec_regularize +! use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' + use io_units !include 'COMMON.IOUNITS' + use names + use energy_data !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' + use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' + ! use REMD !include 'COMMON.REMD' +! use MD !include 'COMMON.MD' + use regularize_ + use compare + implicit none +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + real(kind=8) :: energy_(0:n_ene) + real(kind=8) :: etot + real(kind=8) :: rms,frac,frac_nn,co + integer :: iretcode + + call alloc_compare_arrays + call gen_dist_constr + call sc_conf + call intout + call regularize(nct-nnt+1,etot,rms,cref(1,nnt,1),iretcode) + call etotal(energy_) + energy_(0)=energy_(0)-energy_(14) + etot=energy_(0) + call enerprint(energy_) + call intout + call briefout(0,etot) + if (outpdb) call pdbout(etot,titel(:32),ipdb) + if (outmol2) call mol2out(etot,titel(:32)) + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (iout,'(a,i3)') 'SUMSL return code:',iretcode + return + end subroutine exec_regularize +!----------------------------------------------------------------------------- + subroutine exec_thread +! use MPI_data !include 'COMMON.SETUP' + use compare + implicit none +! include 'DIMENSIONS' +#ifdef MP + include "mpif.h" +#endif + call alloc_compare_arrays + call thread_seq + return + end subroutine exec_thread +!----------------------------------------------------------------------------- + subroutine exec_MC +! use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL' + use geometry_data + use energy_data + use mcm_md + implicit none +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + character(len=10) :: nodeinfo + real(kind=8) :: varia(6*nres) !(maxvar) (maxvar=6*maxres) + integer :: ipar +#ifdef MPI + include "mpif.h" +#endif + call alloc_MCM_arrays + call mcm_setup + if (minim) then +#ifdef MPI + if (modecalc.eq.3) then + call do_mcm(ipar) + else + call entmcm + endif +#else + if (modecalc.eq.3) then + call do_mcm(ipar) + else + call entmcm + endif +#endif + else + call monte_carlo + endif + return + end subroutine exec_MC +!----------------------------------------------------------------------------- + subroutine exec_mult_eeval_or_minim + use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' + use io_units !include 'COMMON.IOUNITS' + use names + use energy_data !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' + use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' +! use REMD !include 'COMMON.REMD' +! use MD !include 'COMMON.MD' + use io_base + use geometry, only:chainbuild,geom_to_var,int_from_cart1,var_to_geom + use energy, only:etotal,enerprint + use compare, only:rms_nac_nnc + use minimm, only:minimize!,minim_mcmf +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + use minimm, only:minim_mcmf + implicit none + include 'mpif.h' + integer :: ierror,ierr + real(kind=8) :: man + real(kind=8),dimension(mpi_status_size) :: muster +#else + implicit none +#endif + real(kind=8) :: varia(6*nres) !(maxvar) (maxvar=6*maxres) + integer,dimension(6) :: ind + real(kind=8) :: energy_(0:n_ene) + logical :: eof + real(kind=8) :: etot,ene0 + integer :: mm,imm,nft,n,iconf,nmin,i,iretcode,nfun,it,& + nf_mcmf,j + real(kind=8) :: rms,frac,frac_nn,co,time,ene + + eof=.false. +#ifdef MPI + if(me.ne.king) then + call minim_mcmf + return + endif + + close (intin) + open(intin,file=intinname,status='old') + write (istat,'(a5,20a12)')"# ",& + (wname(print_order(i)),i=1,nprint_ene) + if (refstr) then + write (istat,'(a5,20a12)')"# ",& + (ename(print_order(i)),i=1,nprint_ene),& + "ETOT total","RMSD","nat.contact","nnt.contact" + else + write (istat,'(a5,20a12)')"# ",& + (ename(print_order(i)),i=1,nprint_ene),"ETOT total" + endif + + if (.not.minim) then + do while (.not. eof) + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene + call read_x(intin,*11) +#ifdef MPI +! Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) & + call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=1100,err=1100) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + write (iout,'(a,i7)') 'Conformation #',iconf + call etotal(energy_) + call briefout(iconf,energy_(0)) + call enerprint(energy_) + etot=energy_(0) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,20(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot,& + rms,frac,frac_nn,co +!jlee end + else + write (istat,'(i5,16(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot + endif + enddo +1100 continue + goto 1101 + endif + + mm=0 + imm=0 + nft=0 + ene0=0.0d0 + n=0 + iconf=0 +! do n=1,nzsc + do while (.not. eof) + mm=mm+1 + if (mm.lt.nodes) then + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene + call read_x(intin,*11) +#ifdef MPI +! Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) & + call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=11,err=11) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + write (iout,'(a,i7)') 'Conformation #',iconf + n=n+1 + imm=imm+1 + ind(1)=1 + ind(2)=n + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + ene0=0.0d0 + call mpi_send(ind,6,mpi_integer,mm,idint,CG_COMM,& + ierr) + call mpi_send(varia,nvar,mpi_double_precision,mm,& + idreal,CG_COMM,ierr) + call mpi_send(ene0,1,mpi_double_precision,mm,& + idreal,CG_COMM,ierr) +! print *,'task ',n,' sent to worker ',mm,nvar + else + call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint,& + CG_COMM,muster,ierr) + man=muster(mpi_source) +! print *,'receiving result from worker ',man,' (',iii1,iii,')' + call mpi_recv(varia,nvar,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) + call mpi_recv(ene,1,& + mpi_double_precision,man,idreal,& + CG_COMM,muster,ierr) + call mpi_recv(ene0,1,& + mpi_double_precision,man,idreal,& + CG_COMM,muster,ierr) +! print *,'result received from worker ',man,' sending now' + + call var_to_geom(nvar,varia) + call chainbuild + call etotal(energy_) + iconf=ind(2) + write (iout,*) + write (iout,*) + write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) + + etot=energy_(0) + call enerprint(energy_) + call briefout(it,etot) +! if (minim) call briefout(it,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,19(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot,& + rms,frac,frac_nn,co + else + write (istat,'(i5,15(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot + endif + + imm=imm-1 + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=1101,err=1101) time,ene + call read_x(intin,*11) +#ifdef MPI +! Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) & + call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=1101,err=1101) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + n=n+1 + imm=imm+1 + ind(1)=1 + ind(2)=n + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + call mpi_send(ind,6,mpi_integer,man,idint,CG_COMM,& + ierr) + call mpi_send(varia,nvar,mpi_double_precision,man,& + idreal,CG_COMM,ierr) + call mpi_send(ene0,1,mpi_double_precision,man,& + idreal,CG_COMM,ierr) + nf_mcmf=nf_mcmf+ind(4) + nmin=nmin+1 + endif + enddo +11 continue + do j=1,imm + call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint,& + CG_COMM,muster,ierr) + man=muster(mpi_source) + call mpi_recv(varia,nvar,mpi_double_precision,& + man,idreal,CG_COMM,muster,ierr) + call mpi_recv(ene,1,& + mpi_double_precision,man,idreal,& + CG_COMM,muster,ierr) + call mpi_recv(ene0,1,& + mpi_double_precision,man,idreal,& + CG_COMM,muster,ierr) + + call var_to_geom(nvar,varia) + call chainbuild + call etotal(energy_) + iconf=ind(2) + write (iout,*) + write (iout,*) + write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) + + etot=energy_(0) + call enerprint(energy_) + call briefout(it,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,19(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot,& + rms,frac,frac_nn,co + else + write (istat,'(i5,15(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot + endif + nmin=nmin+1 + enddo +1101 continue + do i=1, nodes-1 + ind(1)=0 + ind(2)=0 + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM,& + ierr) + enddo +#else + close (intin) + open(intin,file=intinname,status='old') + write (istat,'(a5,20a12)')"# ",& + (wname(print_order(i)),i=1,nprint_ene) + write (istat,'("# ",20(1pe12.4))') & + (weights(print_order(i)),i=1,nprint_ene) + if (refstr) then + write (istat,'(a5,20a12)')"# ",& + (ename(print_order(i)),i=1,nprint_ene),& + "ETOT total","RMSD","nat.contact","nnt.contact" + else + write (istat,'(a5,14a12)')"# ",& + (ename(print_order(i)),i=1,nprint_ene),"ETOT total" + endif + do while (.not. eof) + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene + call read_x(intin,*11) +#ifdef MPI +! Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) & + call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=11,err=11) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + write (iout,'(a,i7)') 'Conformation #',iconf + if (minim) call minimize(etot,varia,iretcode,nfun) + call etotal(energy_) + + etot=energy_(0) + call enerprint(energy_) + if (minim) call briefout(it,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,18(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),& + etot,rms,frac,frac_nn,co +!jlee end + else + write (istat,'(i5,14(f12.3))') iconf,& + (energy_(print_order(i)),i=1,nprint_ene),etot + endif + enddo + 11 continue +#endif + return + end subroutine exec_mult_eeval_or_minim +!----------------------------------------------------------------------------- + subroutine exec_checkgrad +! use MPI_data !include 'COMMON.SETUP' + use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' + use io_units !include 'COMMON.IOUNITS' +!el use energy_data, only:icall !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' + use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' +! use REMD !include 'COMMON.REMD' + use MD_data !include 'COMMON.MD' + use io_base, only:intout + use io_config, only:read_fragments + use geometry + use energy + use comm_srutu + implicit none +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +!el integer :: icall +!el common /srutu/ icall + real(kind=8) :: energy_(0:max_ene) + real(kind=8) :: etot + integer :: i +! do i=2,nres +! vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0) +! if (itype(i).ne.10) +! & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0) +! enddo + if (indpdb.eq.0) call chainbuild +! do i=0,nres +! do j=1,3 +! dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0) +! enddo +! enddo +! do i=1,nres-1 +! if (itype(i).ne.10) then +! do j=1,3 +! dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0) +! enddo +! endif +! enddo +! do j=1,3 +! dc(j,0)=ran_number(-0.2d0,0.2d0) +! enddo + usampl=.true. + totT=1.d0 + eq_time=0.0d0 + call read_fragments + call chainbuild_cart + call cartprint + call intout + icall=1 + call etotal(energy_(0)) + etot = energy_(0) + call enerprint(energy_(0)) + write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back + print *,'icheckgrad=',icheckgrad + goto (10,20,30) icheckgrad + 10 call check_ecartint + return + 20 call check_cartgrad + return + 30 call check_eint + return + end subroutine exec_checkgrad +!----------------------------------------------------------------------------- + subroutine exec_map +! use map_data + use map_ + use io_config, only:map_read + implicit none +! Energy maps + call alloc_map_arrays + call map_read + call map + return + end subroutine exec_map +!----------------------------------------------------------------------------- + subroutine exec_CSA + + use io_units !include 'COMMON.IOUNITS' + use CSA + + implicit none +#ifdef MPI + include "mpif.h" +#endif +! include 'DIMENSIONS' +! Conformational Space Annealling programmed by Jooyoung Lee. +! This method works only with parallel machines! +#ifdef MPI + call alloc_CSA_arrays + call together +#else + write (iout,*) "CSA works on parallel machines only" +#endif + return + end subroutine exec_CSA +!----------------------------------------------------------------------------- + subroutine exec_softreg + use io_units !include 'COMMON.IOUNITS' + use control_data !include 'COMMON.CONTROL' + use energy_data + use io_base, only:intout,briefout + use geometry, only:chainbuild + use energy + use compare + implicit none +! include 'DIMENSIONS' + real(kind=8) :: energy_(0:n_ene) +!el local variables + real(kind=8) :: rms,frac,frac_nn,co,etot + logical :: debug + + call alloc_compare_arrays + call chainbuild + call etotal(energy_) + call enerprint(energy_) + if (.not.lsecondary) then + write(iout,*) 'Calling secondary structure recognition' + call secondary2(debug) + else + write(iout,*) 'Using secondary structure supplied in pdb' + endif + + call softreg + + call etotal(energy_) + etot=energy_(0) + call enerprint(energy_) + call intout + call briefout(0,etot) + call secondary2(.true.) + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + return + end subroutine exec_softreg +!----------------------------------------------------------------------------- +! minimize_p.F +!----------------------------------------------------------------------------- +!el#ifdef MPI + subroutine ergastulum + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use MD_data + use energy + use MDyn, only:setup_fricmat + use REMD, only:fricmat_mult,ginv_mult +#ifdef MPI + include "mpif.h" +#endif +! include 'COMMON.SETUP' +! include 'COMMON.DERIV' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.FFIELD' +! include 'COMMON.INTERACT' +! include 'COMMON.MD' +! include 'COMMON.TIME1' + real(kind=8),dimension(6*nres) :: z,d_a_tmp !(maxres6) maxres6=6*maxres + real(kind=8) :: edum(0:n_ene),time_order(0:10) +!el real(kind=8),dimension(2*nres,2*nres) :: Gcopy !(maxres2,maxres2) maxres2=2*maxres +!el common /przechowalnia/ Gcopy + integer :: icall = 0 + +!el local variables + real(kind=8) :: time00 + integer :: iorder,i,j,nres2,ierr,ierror + nres2=2*nres + if(.not.allocated(Gcopy)) allocate(Gcopy(nres2,nres2)) +! common.MD + if(.not.allocated(Ginv)) allocate(Ginv(nres2,nres2)) !(maxres2,maxres2) +! common /mdpmpi/ + if(.not.allocated(ng_start)) allocate(ng_start(0:nfgtasks-1)) + if(.not.allocated(ng_counts)) allocate(ng_counts(0:nfgtasks-1)) + if(.not.allocated(nginv_counts)) allocate(nginv_counts(0:nfgtasks-1)) !(0:MaxProcs-1) + if(.not.allocated(nginv_start)) allocate(nginv_start(0:nfgtasks)) !(0:MaxProcs) + + if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) !maxres2=2*maxres + +! Workers wait for variables and NF, and NFL from the boss + iorder=0 + do while (iorder.ge.0) +! write (*,*) 'Processor',fg_rank,' CG group',kolor, +! & ' receives order from Master' + time00=MPI_Wtime() + call MPI_Bcast(iorder,1,MPI_INTEGER,king,FG_COMM,IERR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 + if (icall.gt.4 .and. iorder.ge.0) & + time_order(iorder)=time_order(iorder)+MPI_Wtime()-time00 + icall=icall+1 +! write (*,*) +! & 'Processor',fg_rank,' completed receive MPI_BCAST order',iorder + if (iorder.eq.0) then + call zerograd + call etotal(edum) +! write (2,*) "After etotal" +! write (2,*) "dimen",dimen," dimen3",dimen3 +! call flush(2) + else if (iorder.eq.2) then + call zerograd + call etotal_short(edum) +! write (2,*) "After etotal_short" +! write (2,*) "dimen",dimen," dimen3",dimen3 +! call flush(2) + else if (iorder.eq.3) then + call zerograd + call etotal_long(edum) +! write (2,*) "After etotal_long" +! write (2,*) "dimen",dimen," dimen3",dimen3 +! call flush(2) + else if (iorder.eq.1) then + call sum_gradient +! write (2,*) "After sum_gradient" +! write (2,*) "dimen",dimen," dimen3",dimen3 +! call flush(2) + else if (iorder.eq.4) then + call ginv_mult(z,d_a_tmp) + else if (iorder.eq.5) then +! Setup MD things for a slave + dimen=(nct-nnt+1)+nside + dimen1=(nct-nnt)+(nct-nnt+1) + dimen3=dimen*3 +! write (2,*) "dimen",dimen," dimen3",dimen3 +! call flush(2) + call int_bounds(dimen,igmult_start,igmult_end) + igmult_start=igmult_start-1 + call MPI_Allgather(3*igmult_start,1,MPI_INTEGER,& + ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + my_ng_count=igmult_end-igmult_start + call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1,& + MPI_INTEGER,FG_COMM,IERROR) + write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) !sp +! write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) + myginv_ng_count=nres2*my_ng_count !el maxres2 +! write (2,*) "igmult_start",igmult_start," igmult_end", +! & igmult_end," my_ng_count",my_ng_count +! call flush(2) + call MPI_Allgather(nres2*igmult_start,1,MPI_INTEGER,& !el maxres2 + nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER,& + nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) +! write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) +! write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) +! call flush(2) +! call MPI_Barrier(FG_COMM,IERROR) + time00=MPI_Wtime() + call MPI_Scatterv(ginv(1,1),nginv_counts(0),& + nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1),& + myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +#ifdef TIMING + time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 +#endif + do i=1,dimen + do j=1,2*my_ng_count + ginv(j,i)=gcopy(i,j) + enddo + enddo +! write (2,*) "dimen",dimen," dimen3",dimen3 +! write (2,*) "End MD setup" +! call flush(2) +! write (iout,*) "My chunk of ginv_block" +! call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) + else if (iorder.eq.6) then + call int_from_cart1(.false.) + else if (iorder.eq.7) then + call chainbuild_cart + else if (iorder.eq.8) then + call intcartderiv + else if (iorder.eq.9) then + call fricmat_mult(z,d_a_tmp) + else if (iorder.eq.10) then + call setup_fricmat + endif + enddo + write (*,*) 'Processor',fg_rank,' CG group',kolor,& + ' absolute rank',myrank,' leves ERGASTULUM.' + write(*,*)'Processor',fg_rank,' wait times for respective orders',& + (' order[',i,']',time_order(i),i=0,10) + return + end subroutine ergastulum diff --git a/source/unres/unres.f90 b/source/unres/unres.f90 deleted file mode 100644 index 89feccc..0000000 --- a/source/unres/unres.f90 +++ /dev/null @@ -1,1055 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! U N R E S ! -! ! -! Program to carry out conformational search of proteins in an united-residue ! -! approximation. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - program unres - - use io_units - use control_data - use control, only:tcpu - use io_base, only:ilen - use geometry, only:chainbuild - use control, only:dajczas - use check_bond_ - use energy - use compare, only: test - use map_ - use MDyn - use MPI_ - use io, only:readrtns - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - use MPI_data ! include 'COMMON.SETUP' - implicit none - include 'mpif.h' - integer :: ierr -#else - use MPI_data, only: me,king - implicit none -#endif -! include 'COMMON.TIME1' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.GEO' -! include 'COMMON.HEADER' -! include 'COMMON.CONTROL' -! include 'COMMON.CONTACTS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.REMD' -! include 'COMMON.MD' -! include 'COMMON.SBRIDGE' - - real(kind=8) :: hrtime,mintime,sectime - character(len=64) :: text_mode_calc(-2:14) - text_mode_calc(-2) = 'test' - text_mode_calc(-1) = 'cos' - text_mode_calc(0) = 'Energy evaluation or minimization' - text_mode_calc(1) = 'Regularization of PDB structure' - text_mode_calc(2) = 'Threading of a sequence on PDB structures' - text_mode_calc(3) = 'Monte Carlo (with minimization) ' - text_mode_calc(4) = 'Energy minimization of multiple conformations' - text_mode_calc(5) = 'Checking energy gradient' - text_mode_calc(6) = 'Entropic sampling Monte Carlo (with minimization)' - text_mode_calc(7) = 'Energy map' - text_mode_calc(8) = 'CSA calculations' - text_mode_calc(9) = 'Not used 9' - text_mode_calc(10) = 'Not used 10' - text_mode_calc(11) = 'Soft regularization of PDB structure' - text_mode_calc(12) = 'Mesoscopic molecular dynamics (MD) ' - text_mode_calc(13) = 'Not used 13' - text_mode_calc(14) = 'Replica exchange molecular dynamics (REMD)' -! external ilen -! call memmon_print_usage() - - call init_task - if (me.eq.king) & - write(iout,*)'### LAST MODIFIED 09/03/15 15:32PM by EL' - if (me.eq.king) call cinfo -! Read force field parameters and job setup data - call readrtns - call flush(iout) -! - if (me.eq.king .or. .not. out1file) then - write (iout,'(2a/)') & - text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))), & - ' calculation.' - if (minim) write (iout,'(a)') & - 'Conformations will be energy-minimized.' - write (iout,'(80(1h*)/)') - endif - call flush(iout) -! - if (modecalc.eq.-2) then - call test - stop - else if (modecalc.eq.-1) then - write(iout,*) "call check_sc_map next" - call check_bond - stop - endif -!elwrite(iout,*)"!!!!!!!!!!!!!!!!! in unres" - -#ifdef MPI - if (fg_rank.gt.0) then -! Fine-grain slaves just do energy and gradient components. - call ergastulum ! slave workhouse in Latin - else -#endif - if (modecalc.eq.0) then -!write(iout,*)"!!!!!!!!!!!!!!!!! in unres" - - call exec_eeval_or_minim -!write(iout,*)"!!!!!!!!!!!!!!!!! in unres" - - else if (modecalc.eq.1) then - call exec_regularize - else if (modecalc.eq.2) then - call exec_thread - else if (modecalc.eq.3 .or. modecalc .eq.6) then - call exec_MC - else if (modecalc.eq.4) then - call exec_mult_eeval_or_minim - else if (modecalc.eq.5) then - call exec_checkgrad -!write(iout,*) "check grad dwa razy" -!el call exec_checkgrad - else if (ModeCalc.eq.7) then - call exec_map - else if (ModeCalc.eq.8) then - call exec_CSA - else if (modecalc.eq.11) then - call exec_softreg - else if (modecalc.eq.12) then - call exec_MD - else if (modecalc.eq.14) then - call exec_MREMD - else - write (iout,'(a)') 'This calculation type is not supported',& - ModeCalc - endif -!elwrite(iout,*)"!!!!!!!!!!!!!!!!!" - -#ifdef MPI - endif -! Finish task. - if (fg_rank.eq.0) call finish_task -! call memmon_print_usage() -#ifdef TIMING - call print_detailed_timing -#endif - call MPI_Finalize(ierr) - stop 'Bye Bye...' -#else - call dajczas(tcpu(),hrtime,mintime,sectime) - stop '********** Program terminated normally.' -#endif - - end program !UNRES -!----------------------------------------------------------------------------- -! -!----------------------------------------------------------------------------- - subroutine exec_MD - use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL' - use geometry, only:chainbuild - use MDyn - use io_units !include 'COMMON.IOUNITS' -! use io_common - implicit none -! include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - call alloc_MD_arrays - if (me.eq.king .or. .not. out1file) & - write (iout,*) "Calling chainbuild" - call chainbuild - call MD - return - end subroutine exec_MD -!--------------------------------------------------------------------------- - subroutine exec_MREMD - use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL' - use io_units !include 'COMMON.IOUNITS' -! use io_common - use REMD_data !include 'COMMON.REMD' - use geometry, only:chainbuild - use MREMDyn - - implicit none -! include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - - integer :: i - call alloc_MD_arrays - call alloc_MREMD_arrays - - if (me.eq.king .or. .not. out1file) & - write (iout,*) "Calling chainbuild" - call chainbuild - if (me.eq.king .or. .not. out1file) & - write (iout,*) "Calling REMD" - if (remd_mlist) then - call MREMD - else - do i=1,nrep - remd_m(i)=1 - enddo - call MREMD - endif - return - end subroutine exec_MREMD -!----------------------------------------------------------------------------- - subroutine exec_eeval_or_minim - use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' - use io_units !include 'COMMON.IOUNITS' - use names -! use energy !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' - use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' -! use REMD !include 'COMMON.REMD' -! use MD !include 'COMMON.MD' - - use energy_data - - use io_base - use geometry, only:chainbuild - use energy - use compare, only:alloc_compare_arrays,hairpin,secondary2,rms_nac_nnc - use minimm, only:minimize,minim_dc,sc_move - use compare_data !el - use comm_srutu - implicit none -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - integer :: i -!el common /srutu/ icall - real(kind=8) :: energy_(0:n_ene) - real(kind=8) :: energy_long(0:n_ene),energy_short(0:n_ene) - real(kind=8) :: varia(6*nres) !(maxvar) (maxvar=6*maxres) - real(kind=8) :: time00, evals, etota, etot, time_ene, time1 - integer :: nharp,nft_sc,iretcode,nfun - integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) - logical :: fail - real(kind=8) :: rms,frac,frac_nn,co - - integer :: j,k - call alloc_compare_arrays - if (indpdb.eq.0) call chainbuild -#ifdef MPI - time00=MPI_Wtime() -#endif - call chainbuild_cart -! write(iout,*)"in exec_eeval or minimim",split_ene -! do j=1,2*nres+2 -! write(iout,*)"cccccc",j,(c(i,j),i=1,3) -! write(iout,*)"dcccccc",j,(dc(i,j),i=1,3) -! enddo - if (split_ene) then -! write(iout,*)"in exec_eeval or minimim" - - print *,"Processor",myrank," after chainbuild" - icall=1 -!elwrite(iout,*)"in exec_eeval or minimim" - - call etotal_long(energy_long) - write (iout,*) "Printing long range energy" - call enerprint(energy_long) -!elwrite(iout,*)"in exec_eeval or minimim" - - call etotal_short(energy_short) - write (iout,*) "Printing short range energy" - call enerprint(energy_short) - do i=0,n_ene - energy_(i)=energy_long(i)+energy_short(i) - write (iout,*) i,energy_long(i),energy_short(i),energy_(i) - enddo - write (iout,*) "Printing long+short range energy" - call enerprint(energy_) - endif - - call etotal(energy_) -!elwrite(iout,*)"after etotal in exec_eev" -#ifdef MPI - time_ene=MPI_Wtime()-time00 -#endif - write (iout,*) "Time for energy evaluation",time_ene - print *,"after etotal" - etota = energy_(0) - etot = etota - call enerprint(energy_) -!write(iout,*)"after enerprint" - call hairpin(.true.,nharp,iharp) -!write(iout,*) "after hairpin"!,hfrag(1,1) - call secondary2(.true.) -!write(iout,*) "after secondary2" - if (minim) then -!rc overlap test -!elwrite(iout,*) "after secondary2 minim",minim - if (overlapsc) then - print *, 'Calling OVERLAP_SC' -!write(iout,*) 'Calling OVERLAP_SC' - call overlap_sc(fail) -!write(iout,*) 'after Calling OVERLAP_SC' - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - write(iout,*) 'SC_move',nft_sc,etot - endif - - if (dccart) then -!write(iout,*) 'CART calling minim_dc', nvar - print *, 'Calling MINIM_DC' -#ifdef MPI - time1=MPI_WTIME() -#endif -! call check_ecartint !el - call minim_dc(etot,iretcode,nfun) -! call check_ecartint !el - else -!write(iout,*) "indpdb",indpdb - if (indpdb.ne.0) then -!write(iout,*) 'if indpdb', indpdb - call bond_regular - call chainbuild - endif - call geom_to_var(nvar,varia) -!write(iout,*) 'po geom to var; calling minimize', nvar - print *,'Calling MINIMIZE.' -#ifdef MPI - time1=MPI_WTIME() -#endif -! call check_eint -! call exec_checkgrad !el - call minimize(etot,varia,iretcode,nfun) -! call check_eint -! call exec_checkgrad !el - endif - print *,'SUMSL return code is',iretcode,' eval ',nfun -#ifdef MPI - evals=nfun/(MPI_WTIME()-time1) -#endif - print *,'# eval/s',evals - print *,'refstr=',refstr - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call etotal(energy_) - etot = energy_(0) - call enerprint(energy_) - - call intout - call briefout(0,etot) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 - write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals - else -!elwrite(iout,*) "after secondary2 minim",minim - print *,'refstr=',refstr - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) -!elwrite(iout,*) "rms_nac" -!elwrite(iout,*) "before briefout" - call briefout(0,etot) -!elwrite(iout,*) "after briefout" - endif - if (outpdb) call pdbout(etot,titel(:32),ipdb) - if (outmol2) call mol2out(etot,titel(:32)) -!elwrite(iout,*) "after exec_eeval_or_minim" - return - end subroutine exec_eeval_or_minim -!----------------------------------------------------------------------------- - subroutine exec_regularize -! use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' - use io_units !include 'COMMON.IOUNITS' - use names - use energy_data !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' - use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' - ! use REMD !include 'COMMON.REMD' -! use MD !include 'COMMON.MD' - use regularize_ - use compare - implicit none -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - real(kind=8) :: energy_(0:n_ene) - real(kind=8) :: etot - real(kind=8) :: rms,frac,frac_nn,co - integer :: iretcode - - call alloc_compare_arrays - call gen_dist_constr - call sc_conf - call intout - call regularize(nct-nnt+1,etot,rms,cref(1,nnt,1),iretcode) - call etotal(energy_) - energy_(0)=energy_(0)-energy_(14) - etot=energy_(0) - call enerprint(energy_) - call intout - call briefout(0,etot) - if (outpdb) call pdbout(etot,titel(:32),ipdb) - if (outmol2) call mol2out(etot,titel(:32)) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - return - end subroutine exec_regularize -!----------------------------------------------------------------------------- - subroutine exec_thread -! use MPI_data !include 'COMMON.SETUP' - use compare - implicit none -! include 'DIMENSIONS' -#ifdef MP - include "mpif.h" -#endif - call alloc_compare_arrays - call thread_seq - return - end subroutine exec_thread -!----------------------------------------------------------------------------- - subroutine exec_MC -! use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL' - use geometry_data - use energy_data - use mcm_md - implicit none -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - character(len=10) :: nodeinfo - real(kind=8) :: varia(6*nres) !(maxvar) (maxvar=6*maxres) - integer :: ipar -#ifdef MPI - include "mpif.h" -#endif - call alloc_MCM_arrays - call mcm_setup - if (minim) then -#ifdef MPI - if (modecalc.eq.3) then - call do_mcm(ipar) - else - call entmcm - endif -#else - if (modecalc.eq.3) then - call do_mcm(ipar) - else - call entmcm - endif -#endif - else - call monte_carlo - endif - return - end subroutine exec_MC -!----------------------------------------------------------------------------- - subroutine exec_mult_eeval_or_minim - use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' - use io_units !include 'COMMON.IOUNITS' - use names - use energy_data !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' - use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' -! use REMD !include 'COMMON.REMD' -! use MD !include 'COMMON.MD' - use io_base - use geometry, only:chainbuild,geom_to_var,int_from_cart1,var_to_geom - use energy, only:etotal,enerprint - use compare, only:rms_nac_nnc - use minimm, only:minimize!,minim_mcmf -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - use minimm, only:minim_mcmf - implicit none - include 'mpif.h' - integer :: ierror,ierr - real(kind=8) :: man - real(kind=8),dimension(mpi_status_size) :: muster -#else - implicit none -#endif - real(kind=8) :: varia(6*nres) !(maxvar) (maxvar=6*maxres) - integer,dimension(6) :: ind - real(kind=8) :: energy_(0:n_ene) - logical :: eof - real(kind=8) :: etot,ene0 - integer :: mm,imm,nft,n,iconf,nmin,i,iretcode,nfun,it,& - nf_mcmf,j - real(kind=8) :: rms,frac,frac_nn,co,time,ene - - eof=.false. -#ifdef MPI - if(me.ne.king) then - call minim_mcmf - return - endif - - close (intin) - open(intin,file=intinname,status='old') - write (istat,'(a5,20a12)')"# ",& - (wname(print_order(i)),i=1,nprint_ene) - if (refstr) then - write (istat,'(a5,20a12)')"# ",& - (ename(print_order(i)),i=1,nprint_ene),& - "ETOT total","RMSD","nat.contact","nnt.contact" - else - write (istat,'(a5,20a12)')"# ",& - (ename(print_order(i)),i=1,nprint_ene),"ETOT total" - endif - - if (.not.minim) then - do while (.not. eof) - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene - call read_x(intin,*11) -#ifdef MPI -! Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) & - call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1100,err=1100) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - call etotal(energy_) - call briefout(iconf,energy_(0)) - call enerprint(energy_) - etot=energy_(0) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,20(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot,& - rms,frac,frac_nn,co -!jlee end - else - write (istat,'(i5,16(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot - endif - enddo -1100 continue - goto 1101 - endif - - mm=0 - imm=0 - nft=0 - ene0=0.0d0 - n=0 - iconf=0 -! do n=1,nzsc - do while (.not. eof) - mm=mm+1 - if (mm.lt.nodes) then - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene - call read_x(intin,*11) -#ifdef MPI -! Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) & - call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=11,err=11) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - n=n+1 - imm=imm+1 - ind(1)=1 - ind(2)=n - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - ene0=0.0d0 - call mpi_send(ind,6,mpi_integer,mm,idint,CG_COMM,& - ierr) - call mpi_send(varia,nvar,mpi_double_precision,mm,& - idreal,CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,mm,& - idreal,CG_COMM,ierr) -! print *,'task ',n,' sent to worker ',mm,nvar - else - call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint,& - CG_COMM,muster,ierr) - man=muster(mpi_source) -! print *,'receiving result from worker ',man,' (',iii1,iii,')' - call mpi_recv(varia,nvar,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene,1,& - mpi_double_precision,man,idreal,& - CG_COMM,muster,ierr) - call mpi_recv(ene0,1,& - mpi_double_precision,man,idreal,& - CG_COMM,muster,ierr) -! print *,'result received from worker ',man,' sending now' - - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energy_) - iconf=ind(2) - write (iout,*) - write (iout,*) - write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) - - etot=energy_(0) - call enerprint(energy_) - call briefout(it,etot) -! if (minim) call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,19(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot,& - rms,frac,frac_nn,co - else - write (istat,'(i5,15(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot - endif - - imm=imm-1 - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1101,err=1101) time,ene - call read_x(intin,*11) -#ifdef MPI -! Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) & - call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1101,err=1101) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - n=n+1 - imm=imm+1 - ind(1)=1 - ind(2)=n - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - call mpi_send(ind,6,mpi_integer,man,idint,CG_COMM,& - ierr) - call mpi_send(varia,nvar,mpi_double_precision,man,& - idreal,CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,man,& - idreal,CG_COMM,ierr) - nf_mcmf=nf_mcmf+ind(4) - nmin=nmin+1 - endif - enddo -11 continue - do j=1,imm - call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint,& - CG_COMM,muster,ierr) - man=muster(mpi_source) - call mpi_recv(varia,nvar,mpi_double_precision,& - man,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene,1,& - mpi_double_precision,man,idreal,& - CG_COMM,muster,ierr) - call mpi_recv(ene0,1,& - mpi_double_precision,man,idreal,& - CG_COMM,muster,ierr) - - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energy_) - iconf=ind(2) - write (iout,*) - write (iout,*) - write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) - - etot=energy_(0) - call enerprint(energy_) - call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,19(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot,& - rms,frac,frac_nn,co - else - write (istat,'(i5,15(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot - endif - nmin=nmin+1 - enddo -1101 continue - do i=1, nodes-1 - ind(1)=0 - ind(2)=0 - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM,& - ierr) - enddo -#else - close (intin) - open(intin,file=intinname,status='old') - write (istat,'(a5,20a12)')"# ",& - (wname(print_order(i)),i=1,nprint_ene) - write (istat,'("# ",20(1pe12.4))') & - (weights(print_order(i)),i=1,nprint_ene) - if (refstr) then - write (istat,'(a5,20a12)')"# ",& - (ename(print_order(i)),i=1,nprint_ene),& - "ETOT total","RMSD","nat.contact","nnt.contact" - else - write (istat,'(a5,14a12)')"# ",& - (ename(print_order(i)),i=1,nprint_ene),"ETOT total" - endif - do while (.not. eof) - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene - call read_x(intin,*11) -#ifdef MPI -! Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) & - call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=11,err=11) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - if (minim) call minimize(etot,varia,iretcode,nfun) - call etotal(energy_) - - etot=energy_(0) - call enerprint(energy_) - if (minim) call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,18(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),& - etot,rms,frac,frac_nn,co -!jlee end - else - write (istat,'(i5,14(f12.3))') iconf,& - (energy_(print_order(i)),i=1,nprint_ene),etot - endif - enddo - 11 continue -#endif - return - end subroutine exec_mult_eeval_or_minim -!----------------------------------------------------------------------------- - subroutine exec_checkgrad -! use MPI_data !include 'COMMON.SETUP' - use control_data !include 'COMMON.CONTROL''COMMON.TIME1''COMMON.NAMES''COMMON.HEADER' - use io_units !include 'COMMON.IOUNITS' -!el use energy_data, only:icall !include 'COMMON.INTERACT''COMMON.CONTACTS''COMMON.VAR''COMMON.FFIELD' 'COMMON.SBRIDGE' - use geometry_data !include 'COMMON.GEO''COMMON.CHAIN' -! use REMD !include 'COMMON.REMD' - use MD_data !include 'COMMON.MD' - use io_base, only:intout - use io_config, only:read_fragments - use geometry - use energy - use comm_srutu - implicit none -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -!el integer :: icall -!el common /srutu/ icall - real(kind=8) :: energy_(0:max_ene) - real(kind=8) :: etot - integer :: i -! do i=2,nres -! vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0) -! if (itype(i).ne.10) -! & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0) -! enddo - if (indpdb.eq.0) call chainbuild -! do i=0,nres -! do j=1,3 -! dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0) -! enddo -! enddo -! do i=1,nres-1 -! if (itype(i).ne.10) then -! do j=1,3 -! dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0) -! enddo -! endif -! enddo -! do j=1,3 -! dc(j,0)=ran_number(-0.2d0,0.2d0) -! enddo - usampl=.true. - totT=1.d0 - eq_time=0.0d0 - call read_fragments - call chainbuild_cart - call cartprint - call intout - icall=1 - call etotal(energy_(0)) - etot = energy_(0) - call enerprint(energy_(0)) - write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back - print *,'icheckgrad=',icheckgrad - goto (10,20,30) icheckgrad - 10 call check_ecartint - return - 20 call check_cartgrad - return - 30 call check_eint - return - end subroutine exec_checkgrad -!----------------------------------------------------------------------------- - subroutine exec_map -! use map_data - use map_ - use io_config, only:map_read - implicit none -! Energy maps - call alloc_map_arrays - call map_read - call map - return - end subroutine exec_map -!----------------------------------------------------------------------------- - subroutine exec_CSA - - use io_units !include 'COMMON.IOUNITS' - use CSA - - implicit none -#ifdef MPI - include "mpif.h" -#endif -! include 'DIMENSIONS' -! Conformational Space Annealling programmed by Jooyoung Lee. -! This method works only with parallel machines! -#ifdef MPI - call alloc_CSA_arrays - call together -#else - write (iout,*) "CSA works on parallel machines only" -#endif - return - end subroutine exec_CSA -!----------------------------------------------------------------------------- - subroutine exec_softreg - use io_units !include 'COMMON.IOUNITS' - use control_data !include 'COMMON.CONTROL' - use energy_data - use io_base, only:intout,briefout - use geometry, only:chainbuild - use energy - use compare - implicit none -! include 'DIMENSIONS' - real(kind=8) :: energy_(0:n_ene) -!el local variables - real(kind=8) :: rms,frac,frac_nn,co,etot - logical :: debug - - call alloc_compare_arrays - call chainbuild - call etotal(energy_) - call enerprint(energy_) - if (.not.lsecondary) then - write(iout,*) 'Calling secondary structure recognition' - call secondary2(debug) - else - write(iout,*) 'Using secondary structure supplied in pdb' - endif - - call softreg - - call etotal(energy_) - etot=energy_(0) - call enerprint(energy_) - call intout - call briefout(0,etot) - call secondary2(.true.) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - return - end subroutine exec_softreg -!----------------------------------------------------------------------------- -! minimize_p.F -!----------------------------------------------------------------------------- -!el#ifdef MPI - subroutine ergastulum - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use MD_data - use energy - use MDyn, only:setup_fricmat - use REMD, only:fricmat_mult,ginv_mult -#ifdef MPI - include "mpif.h" -#endif -! include 'COMMON.SETUP' -! include 'COMMON.DERIV' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.FFIELD' -! include 'COMMON.INTERACT' -! include 'COMMON.MD' -! include 'COMMON.TIME1' - real(kind=8),dimension(6*nres) :: z,d_a_tmp !(maxres6) maxres6=6*maxres - real(kind=8) :: edum(0:n_ene),time_order(0:10) -!el real(kind=8),dimension(2*nres,2*nres) :: Gcopy !(maxres2,maxres2) maxres2=2*maxres -!el common /przechowalnia/ Gcopy - integer :: icall = 0 - -!el local variables - real(kind=8) :: time00 - integer :: iorder,i,j,nres2,ierr,ierror - nres2=2*nres - if(.not.allocated(Gcopy)) allocate(Gcopy(nres2,nres2)) -! common.MD - if(.not.allocated(Ginv)) allocate(Ginv(nres2,nres2)) !(maxres2,maxres2) -! common /mdpmpi/ - if(.not.allocated(ng_start)) allocate(ng_start(0:nfgtasks-1)) - if(.not.allocated(ng_counts)) allocate(ng_counts(0:nfgtasks-1)) - if(.not.allocated(nginv_counts)) allocate(nginv_counts(0:nfgtasks-1)) !(0:MaxProcs-1) - if(.not.allocated(nginv_start)) allocate(nginv_start(0:nfgtasks)) !(0:MaxProcs) - - if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2)) !maxres2=2*maxres - -! Workers wait for variables and NF, and NFL from the boss - iorder=0 - do while (iorder.ge.0) -! write (*,*) 'Processor',fg_rank,' CG group',kolor, -! & ' receives order from Master' - time00=MPI_Wtime() - call MPI_Bcast(iorder,1,MPI_INTEGER,king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - if (icall.gt.4 .and. iorder.ge.0) & - time_order(iorder)=time_order(iorder)+MPI_Wtime()-time00 - icall=icall+1 -! write (*,*) -! & 'Processor',fg_rank,' completed receive MPI_BCAST order',iorder - if (iorder.eq.0) then - call zerograd - call etotal(edum) -! write (2,*) "After etotal" -! write (2,*) "dimen",dimen," dimen3",dimen3 -! call flush(2) - else if (iorder.eq.2) then - call zerograd - call etotal_short(edum) -! write (2,*) "After etotal_short" -! write (2,*) "dimen",dimen," dimen3",dimen3 -! call flush(2) - else if (iorder.eq.3) then - call zerograd - call etotal_long(edum) -! write (2,*) "After etotal_long" -! write (2,*) "dimen",dimen," dimen3",dimen3 -! call flush(2) - else if (iorder.eq.1) then - call sum_gradient -! write (2,*) "After sum_gradient" -! write (2,*) "dimen",dimen," dimen3",dimen3 -! call flush(2) - else if (iorder.eq.4) then - call ginv_mult(z,d_a_tmp) - else if (iorder.eq.5) then -! Setup MD things for a slave - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -! write (2,*) "dimen",dimen," dimen3",dimen3 -! call flush(2) - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER,& - ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1,& - MPI_INTEGER,FG_COMM,IERROR) - write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) !sp -! write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - myginv_ng_count=nres2*my_ng_count !el maxres2 -! write (2,*) "igmult_start",igmult_start," igmult_end", -! & igmult_end," my_ng_count",my_ng_count -! call flush(2) - call MPI_Allgather(nres2*igmult_start,1,MPI_INTEGER,& !el maxres2 - nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER,& - nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) -! write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) -! write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) -! call flush(2) -! call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0),& - nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1),& - myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -! write (2,*) "dimen",dimen," dimen3",dimen3 -! write (2,*) "End MD setup" -! call flush(2) -! write (iout,*) "My chunk of ginv_block" -! call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) - else if (iorder.eq.6) then - call int_from_cart1(.false.) - else if (iorder.eq.7) then - call chainbuild_cart - else if (iorder.eq.8) then - call intcartderiv - else if (iorder.eq.9) then - call fricmat_mult(z,d_a_tmp) - else if (iorder.eq.10) then - call setup_fricmat - endif - enddo - write (*,*) 'Processor',fg_rank,' CG group',kolor,& - ' absolute rank',myrank,' leves ERGASTULUM.' - write(*,*)'Processor',fg_rank,' wait times for respective orders',& - (' order[',i,']',time_order(i),i=0,10) - return - end subroutine ergastulum diff --git a/source/wham/CMakeLists.txt b/source/wham/CMakeLists.txt index 5629904..fb3ca0d 100644 --- a/source/wham/CMakeLists.txt +++ b/source/wham/CMakeLists.txt @@ -10,39 +10,39 @@ enable_language (Fortran) # dummy library for automatic dependency set(UNRES_WHAM_SRC_DATA - wham_data.f90 - w_compar_data.f90 - w_comm_local.f90 + 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/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/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 + io_database.F90 + io_wham.F90 + conform_compar.F90 + enecalc.F90 + wham_calc.F90 + work_partition.F90 + wham.F90 ) @@ -154,9 +154,9 @@ set(UNRES_WHAM_BIN "wham_${Fortran_COMPILER_NAME}_MPI_${UNRES_MD_FF}.exe") TODAY(DATE) # generate cinfo.f -set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90") +set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.F90") FILE(WRITE ${CINFO} -"! CMake generated file cinfo.f90 +"! CMake generated file cinfo.F90 subroutine cinfo use io_units write(iout,*)'++++ Compile info ++++' @@ -177,13 +177,13 @@ FILE(APPEND ${CINFO} 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 ${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 ) +set(UNRES_WHAM_SRCS ${UNRES_WHAM_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.F90 ) #========================================= # Build the binary @@ -241,21 +241,21 @@ export PREFIX=$1 WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_WHAM_BIN} #----------------------------------------------------------------------------- DD=${CMAKE_SOURCE_DIR}/PARAM -export BONDPAR=$DD/bond_AM1_ext.parm -export THETPAR=$DD/theta_abinitio_old_ext.parm -export THETPARPDB=$DD/thetaml_ext.5parm -export ROTPARPDB=$DD/scgauss_ext.parm -export ROTPAR=$DD/rotamers_AM1_aura_ext.10022007.parm -export TORPAR=$DD/torsion_631Gdp_old_ext.parm -export TORDPAR=$DD/torsion_double_631Gdp_old_ext.parm -export ELEPAR=$DD/electr_631Gdp_ext.parm -export SIDEPAR=$DD/scinter_GB_ext.parm -export FOURIER=$DD/fourier_opt_ext.parm.1igd_hc_iter3_3 -export SCCORPAR=$DD/sccor_am1_pawel_ext.dat -export SCPPAR=$DD/scp_ext.parm +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_ext.3.parm +export SIDEP=$DD/contact.3.parm export SCRATCHDIR=. #----------------------------------------------------------------------------- echo CTEST_FULL_OUTPUT diff --git a/source/wham/cinfo.F90 b/source/wham/cinfo.F90 new file mode 100644 index 0000000..b5814f0 --- /dev/null +++ b/source/wham/cinfo.F90 @@ -0,0 +1,38 @@ +! DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C +! 0 0 1262 + subroutine cinfo +! include 'COMMON.IOUNITS' + use IO_UNITS + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version 0.0 build 1262' + write(iout,*)'compiled Fri Mar 10 14:57:31 2017' + write(iout,*)'compiled by emilial@piasek4' + write(iout,*)'OS name: Linux ' + write(iout,*)'OS release: 3.2.0-111-generic ' + write(iout,*)'OS version:',& + ' #153-Ubuntu SMP Wed Sep 21 21:23:31 UTC 2016 ' + write(iout,*)'flags:' + write(iout,*)'INSTALL_DIR = /users/software/mpich2-1.4.1p1_in...' + write(iout,*)'OPT = -mcmodel=medium -O3 -ip -w' + write(iout,*)'FC= ${INSTALL_DIR}/bin/mpif90' + write(iout,*)'CC = gcc' + write(iout,*)'DEB = -g -CA -CB -check pointer #-check uninit' + write(iout,*)'FFLAGS = -fpp -c ${DEB} #${OPT} #-I. -I./includ...' + write(iout,*)'FFLAGSE = -fpp -c ${DEB} #${OPT} #-I. -I./inclu...' + write(iout,*)'FFLAGS2 = -fpp -c -g -CA -CB #-O0' + write(iout,*)'UNRES_FILE= ../unres' + write(iout,*)'UNRES_DATA_FILE= ../unres/data' + write(iout,*)'data = wham_data.o w_compar_data.o w_comm_local.o' + write(iout,*)'data_unres = names.o io_units.o calc_data.o com...' + write(iout,*)'objects_unres = xdrf/*.o math.o geometry.o \\' + write(iout,*)' io_base.o energy.o control.o regularize.o comp...' + write(iout,*)'objects = conform_compar.o io_database.o io_con...' + write(iout,*)'GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITEL...' + write(iout,*)'GAB: EXE_FILE = ../../bin/wham_GAB_F90_EL.exe' + write(iout,*)'4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE...' + write(iout,*)'4P: EXE_FILE = ../../bin/wham_4P_F90_EL.exe' + write(iout,*)'E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLI...' + write(iout,*)'E0LL2Y: EXE_FILE = ../../bin/wham_E0LL2Y_F90_EL...' + write(iout,*)'++++ End of compile info ++++' + return + end diff --git a/source/wham/cinfo.f90 b/source/wham/cinfo.f90 deleted file mode 100644 index b5814f0..0000000 --- a/source/wham/cinfo.f90 +++ /dev/null @@ -1,38 +0,0 @@ -! DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C -! 0 0 1262 - subroutine cinfo -! include 'COMMON.IOUNITS' - use IO_UNITS - write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version 0.0 build 1262' - write(iout,*)'compiled Fri Mar 10 14:57:31 2017' - write(iout,*)'compiled by emilial@piasek4' - write(iout,*)'OS name: Linux ' - write(iout,*)'OS release: 3.2.0-111-generic ' - write(iout,*)'OS version:',& - ' #153-Ubuntu SMP Wed Sep 21 21:23:31 UTC 2016 ' - write(iout,*)'flags:' - write(iout,*)'INSTALL_DIR = /users/software/mpich2-1.4.1p1_in...' - write(iout,*)'OPT = -mcmodel=medium -O3 -ip -w' - write(iout,*)'FC= ${INSTALL_DIR}/bin/mpif90' - write(iout,*)'CC = gcc' - write(iout,*)'DEB = -g -CA -CB -check pointer #-check uninit' - write(iout,*)'FFLAGS = -fpp -c ${DEB} #${OPT} #-I. -I./includ...' - write(iout,*)'FFLAGSE = -fpp -c ${DEB} #${OPT} #-I. -I./inclu...' - write(iout,*)'FFLAGS2 = -fpp -c -g -CA -CB #-O0' - write(iout,*)'UNRES_FILE= ../unres' - write(iout,*)'UNRES_DATA_FILE= ../unres/data' - write(iout,*)'data = wham_data.o w_compar_data.o w_comm_local.o' - write(iout,*)'data_unres = names.o io_units.o calc_data.o com...' - write(iout,*)'objects_unres = xdrf/*.o math.o geometry.o \\' - write(iout,*)' io_base.o energy.o control.o regularize.o comp...' - write(iout,*)'objects = conform_compar.o io_database.o io_con...' - write(iout,*)'GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITEL...' - write(iout,*)'GAB: EXE_FILE = ../../bin/wham_GAB_F90_EL.exe' - write(iout,*)'4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE...' - write(iout,*)'4P: EXE_FILE = ../../bin/wham_4P_F90_EL.exe' - write(iout,*)'E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLI...' - write(iout,*)'E0LL2Y: EXE_FILE = ../../bin/wham_E0LL2Y_F90_EL...' - write(iout,*)'++++ End of compile info ++++' - return - end diff --git a/source/wham/conform_compar.F90 b/source/wham/conform_compar.F90 new file mode 100644 index 0000000..701e920 --- /dev/null +++ b/source/wham/conform_compar.F90 @@ -0,0 +1,3559 @@ + module conform_compar +!----------------------------------------------------------------------------- + use names + use io_units + use geometry_data, only:nres + use math, only:pinorm + use geometry, only:dist + use regularize_, only:fitsq +! + use wham_data +#ifndef CLUSTER + use w_compar_data +#endif +#ifdef MPI + use MPI_data +! include "COMMON.MPI" +#endif + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +#ifndef CLUSTER +!----------------------------------------------------------------------------- +! conf_compar.F +!----------------------------------------------------------------------------- + subroutine conf_compar(jcon,lprn,print_class) +! implicit real*8 (a-h,o-z) + use energy_data, only:icont,ncont,nnt,nct,maxcont!,& +! nsccont_frag_ref,isccont_frag_ref +#ifdef MPI + include "mpif.h" +#endif +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'DIMENSIONS.FREE' +! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.PEPTCONT' +! include 'COMMON.CONTACTS1' +! include 'COMMON.HEADER' +! include 'COMMON.FREE' +! include 'COMMON.ENERGIES' +!#ifdef MPI +! include 'COMMON.MPI' +!#endif +! integer ilen +! external ilen + logical :: lprn,print_class + integer :: ncont_frag(mmaxfrag),& + icont_frag(2,maxcont,mmaxfrag),ncontsc,& + icontsc(1,maxcont),nsccont_frag(mmaxfrag),& + isccont_frag(2,maxcont,mmaxfrag) + integer :: isecstr(nres) + integer :: itemp(maxfrag) + character(len=4) :: liczba + real(kind=8) :: Epot,rms + integer :: jcon,i,j,ind,ncnat,nsec_match,ishift,ishif1,ishif2,& + nc_match,ncon_match,iclass_rms,ishifft_rms,ishiff,ishif + integer :: k,kk,iclass_con,iscor,ik,ishifft_con,idig,iex,im +! print *,"Enter conf_compar",jcon + call angnorm12(rmsang) +! Level 1: check secondary and supersecondary structure + call elecont(lprn,ncont,icont,nnt,nct) + if (lprn) then + write (iout,*) "elecont finished" + call flush(iout) + endif + call secondary2(lprn,.false.,ncont,icont,isecstr) + if (lprn) then + write (iout,*) "secondary2 finished" + call flush(iout) + endif + call contact(lprn,ncontsc,icontsc,nnt,nct) + if (lprn) then + write(iout,*) "Assigning electrostatic contacts" + call flush(iout) + endif + call contacts_between_fragments(lprn,3,ncont,icont,ncont_frag,& + icont_frag) + if (lprn) then + write(iout,*) "Assigning sidechain contacts" + call flush(iout) + endif + call contacts_between_fragments(lprn,3,ncontsc,icontsc,& + nsccont_frag,isccont_frag) + if (lprn) then + write(iout,*) "--> After contacts_between_fragments" + call flush(iout) + endif + do i=1,nlevel + do j=1,isnfrag(nlevel+1) + iclass(j,i)=0 + enddo + enddo + do j=1,nfrag(1) + ind = icant(j,j) + if (lprn) then + write (iout,'(80(1h=))') + write (iout,*) "Level",1," fragment",j + write (iout,'(80(1h=))') + endif + call flush(iout) + rmsfrag(j,1)=rmscalc(0,1,j,jcon,lprn) +! Compare electrostatic contacts in the current conf with that in the native +! structure. + if (lprn) write (iout,*) & + "Comparing electrostatic contact map and local structure" + call flush(iout) + ncnat=ncont_frag_ref(ind) +! write (iout,*) "before match_contact:",nc_fragm(j,1), +! & nc_req_setf(j,1) +! call flush(iout) + call match_secondary(j,isecstr,nsec_match,lprn) + if (lprn) write (iout,*) "Fragment",j," nsec_match",& + nsec_match," length",len_frag(j,1)," min_len",& + frac_sec*len_frag(j,1) + if (nsec_match.lt.frac_sec*len_frag(j,1)) then + iclass(j,1)=0 + if (lprn) write (iout,*) "Fragment",j,& + " has incorrect secondary structure" + else + iclass(j,1)=1 + if (lprn) write (iout,*) "Fragment",j,& + " has correct secondary structure" + endif + if (ielecont(j,1).gt.0) then + call match_contact(ishif1,ishif2,nc_match,ncon_match,& + ncont_frag_ref(ind),icont_frag_ref(1,1,ind),& + ncont_frag(ind),icont_frag(1,1,ind),& + j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1),& + nc_req_setf(j,1),istruct(j),.true.,lprn) + else if (isccont(j,1).gt.0) then + call match_contact(ishif1,ishif2,nc_match,ncon_match,& + nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind),& + nsccont_frag(ind),isccont_frag(1,1,ind),& + j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1),& + nc_req_setf(j,1),istruct(j),.true.,lprn) + else if (iloc(j).gt.0) then +! write (iout,*) "n_shif",n_shift(1,j,1),n_shift(2,j,1) + call match_contact(ishif1,ishif2,nc_match,ncon_match,& + 0,icont_frag_ref(1,1,ind),& + ncont_frag(ind),icont_frag(1,1,ind),& + j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1),& + 0,istruct(j),.true.,lprn) +! write (iout,*) "n_shif",n_shift(1,j,1),n_shift(2,j,1) + else + ishif=0 + nc_match=1 + endif + if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2 + ishif=ishif1 + qfrag(j,1)=qwolynes(1,j) + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (lprn) write (iout,*) "ishift",ishif," nc_match",nc_match +! write (iout,*) "j",j," ishif",ishif," rms",rmsfrag(j,1) + if (irms(j,1).gt.0) then + if (rmsfrag(j,1).le.rmscutfrag(1,j,1)) then + iclass_rms=2 + ishifft_rms=0 + else + ishiff=0 + rms=1.0d2 + iclass_rms=0 + do while (rms.gt.rmscutfrag(1,j,1) .and. & + ishiff.lt.n_shift(1,j,1)) + ishiff=ishiff+1 + rms=rmscalc(-ishiff,1,j,jcon,lprn) +! write(iout,*)"jcon,i,j,ishiff",jcon,i,j,-ishiff, +! & " rms",rms," rmscut",rmscutfrag(1,j,1) + if (lprn) write (iout,*) "rms",rmsfrag(j,1) + if (rms.gt.rmscutfrag(1,j,1)) then + rms=rmscalc(ishiff,1,j,jcon,lprn) +! write (iout,*) "jcon,1,j,ishiff",jcon,1,j,ishiff, +! & " rms",rms + endif + if (lprn) write (iout,*) "rms",rmsfrag(j,1) + enddo +! write (iout,*) "After loop: rms",rms, +! & " rmscut",rmscutfrag(1,j,1) +! write (iout,*) "iclass_rms",iclass_rms + if (rms.le.rmscutfrag(1,j,1)) then + ishifft_rms=ishiff + rmsfrag(j,1)=rms + iclass_rms=1 + endif +! write (iout,*) "iclass_rms",iclass_rms + endif +! write (iout,*) "ishif",ishif + if (iabs(ishifft_rms).gt.iabs(ishif)) ishif=ishifft_rms + else + iclass_rms=1 + endif +! write (iout,*) "ishif",ishif," iclass",iclass(j,1), +! & " iclass_rms",iclass_rms + if (nc_match.gt.0 .and. iclass_rms.gt.0) then + if (ishif.eq.0) then + iclass(j,1)=iclass(j,1)+6 + else + iclass(j,1)=iclass(j,1)+2 + endif + endif + ncont_nat(1,j,1)=nc_match + ncont_nat(2,j,1)=ncon_match + ishifft(j,1)=ishif +! write (iout,*) "iclass",iclass(j,1) + enddo +! Next levels: Check arrangements of elementary fragments. + do i=2,nlevel + do j=1,nfrag(i) + if (i .eq. 2) ind = icant(ipiece(1,j,i),ipiece(2,j,i)) + if (lprn) then + write (iout,'(80(1h=))') + write (iout,*) "Level",i," fragment",j + write (iout,'(80(1h=))') + endif +! If an elementary fragment doesn't exist, don't check higher hierarchy levels. + do k=1,npiece(j,i) + ik=ipiece(k,j,i) + if (iclass(ik,1).eq.0) then + iclass(j,i)=0 + goto 12 + endif + enddo + if (i.eq.2 .and. ielecont(j,i).gt.0) then + iclass_con=0 + ishifft_con=0 + if (lprn) write (iout,*) & + "Comparing electrostatic contact map: fragments",& + ipiece(1,j,i),ipiece(2,j,i)," ind",ind + call match_contact(ishif1,ishif2,nc_match,ncon_match,& + ncont_frag_ref(ind),icont_frag_ref(1,1,ind),& + ncont_frag(ind),icont_frag(1,1,ind),& + j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i),& + nc_req_setf(j,i),2,.false.,lprn) + ishif=ishif1 + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (nc_match.gt.0) then + if (ishif.eq.0) then + iclass_con=2 + else + iclass_con=1 + endif + endif + ncont_nat(1,j,i)=nc_match + ncont_nat(2,j,i)=ncon_match + ishifft_con=ishif + else if (i.eq.2 .and. isccont(j,i).gt.0) then + iclass_con=0 + ishifft_con=0 + if (lprn) write (iout,*) & + "Comparing sidechain contact map: fragments",& + ipiece(1,j,i),ipiece(2,j,i)," ind",ind + call match_contact(ishif1,ishif2,nc_match,ncon_match,& + nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind),& + nsccont_frag(ind),isccont_frag(1,1,ind),& + j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i),& + nc_req_setf(j,i),2,.false.,lprn) + ishif=ishif1 + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (nc_match.gt.0) then + if (ishif.eq.0) then + iclass_con=2 + else + iclass_con=1 + endif + endif + ncont_nat(1,j,i)=nc_match + ncont_nat(2,j,i)=ncon_match + ishifft_con=ishif + else if (i.eq.2) then + iclass_con=2 + ishifft_con=0 + endif + if (i.eq.2) qfrag(j,2)=qwolynes(2,j) + if (lprn) write (iout,*) & + "Comparing rms: fragments",& + (ipiece(k,j,i),k=1,npiece(j,i)) + rmsfrag(j,i)=rmscalc(0,i,j,jcon,lprn) + if (irms(j,i).gt.0) then + iclass_rms=0 + ishifft_rms=0 + if (lprn) write (iout,*) "rms",rmsfrag(j,i) +! write (iout,*) "i",i," j",j," rmsfrag",rmsfrag(j,i), +! & " rmscutfrag",rmscutfrag(1,j,i) + if (rmsfrag(j,i).le.rmscutfrag(1,j,i)) then + iclass_rms=2 + ishifft_rms=0 + else + ishif=0 + rms=1.0d2 + do while (rms.gt.rmscutfrag(1,j,i) .and. & + ishif.lt.n_shift(1,j,i)) + ishif=ishif+1 + rms=rmscalc(-ishif,i,j,jcon,lprn) +! print *,"jcon,i,j,ishif",jcon,i,j,-ishif," rms",rms + if (lprn) write (iout,*) "rms",rmsfrag(j,i) + if (rms.gt.rmscutfrag(1,j,i)) then + rms=rmscalc(ishif,i,j,jcon,lprn) +! print *,"jcon,i,j,ishif",jcon,i,j,ishif," rms",rms + endif + if (lprn) write (iout,*) "rms",rms + enddo + if (rms.le.rmscutfrag(1,j,i)) then + ishifft_rms=ishif + rmsfrag(j,i)=rms + iclass_rms=1 + endif + endif + endif + if (irms(j,i).eq.0 .and. ielecont(j,i).eq.0 .and. & + isccont(j,i).eq.0 ) then + write (iout,*) "Error: no measure of comparison specified:",& + " level",i," part",j + stop + endif + if (lprn) & + write (iout,*) "iclass_con",iclass_con," iclass_rms",iclass_rms + if (i.eq.2) then + iclass(j,i) = min0(iclass_con,iclass_rms) + if (iabs(ishifft_rms).gt.iabs(ishifft_con)) then + ishifft(j,i)=ishifft_rms + else + ishifft(j,i)=ishifft_con + endif + else if (i.gt.2) then + iclass(j,i) = iclass_rms + ishifft(j,i)= ishifft_rms + endif + 12 continue + enddo + enddo + rms_nat=rmsnat(jcon) + qnat=qwolynes(0,0) +! Compute the structural class + iscor=0 + IF (.NOT. BINARY) THEN + do i=1,nlevel + IF (I.EQ.1) THEN + do j=1,nfrag(i) + itemp(j)=iclass(j,i) + enddo + do kk=-1,1 + do j=1,nfrag(i) + idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-kk*nfrag(i)-j + iex = 2**idig + im=mod(itemp(j),2) + itemp(j)=itemp(j)/2 +! write (iout,*) "i",i," j",j," idig",idig," iex",iex, +! & " iclass",iclass(j,i)," im",im + iscor=iscor+im*iex + enddo + enddo + ELSE + do j=1,nfrag(i) + idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-j + iex = 2**idig + if (iclass(j,i).gt.0) then + im=1 + else + im=0 + endif +! write (iout,*) "i",i," j",j," idig",idig," iex",iex, +! & " iclass",iclass(j,i)," im",im + iscor=iscor+im*iex + enddo + do j=1,nfrag(i) + idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-nfrag(i)-j + iex = 2**idig + if (iclass(j,i).gt.1) then + im=1 + else + im=0 + endif +! write (iout,*) "i",i," j",j," idig",idig," iex",iex, +! & " iclass",iclass(j,i)," im",im + iscor=iscor+im*iex + enddo + ENDIF + enddo + iscore=iscor + ENDIF + if (print_class) then +#ifdef MPI + write(istat,'(i6,$)') jcon+indstart(me)-1 + write (istat,'(f10.2,$)') (potE(jcon,k),k=1,nParmSet),& + -entfac(jcon) +#else + write(istat,'(i6,$)') jcon + write (istat,'(f10.2,$)') (potE(jcon,k),k=1,nParmSet),& + -entfac(jcon) +#endif + write (istat,'(f8.3,2f6.3,$)') & + rms_nat,qnat,rmsang/(nres-3) + do j=1,nlevel + write(istat,'(1x,$,20(i3,$))') & + (ncont_nat(1,k,j),k=1,nfrag(j)) + if (j.lt.3) then + write(istat,'(1x,$,20(f5.1,f5.2$))') & + (rmsfrag(k,j),qfrag(k,j),k=1,nfrag(j)) + else + write(istat,'(1x,$,20(f5.1$))') & + (rmsfrag(k,j),k=1,nfrag(j)) + endif + write(istat,'(1x,$,20(i1,$))') & + (iclass(k,j),k=1,nfrag(j)) + enddo + if (binary) then + write (istat,'(" ",$)') + do j=1,nlevel + write (istat,'(100(i1,$))')(iclass(k,j),& + k=1,nfrag(j)) + if (j.lt.nlevel) write(iout,'(".",$)') + enddo + write (istat,*) + else + write (istat,'(i10)') iscore + endif + endif + RETURN + END subroutine conf_compar +!----------------------------------------------------------------------------- +! angnorm.f +!----------------------------------------------------------------------------- + subroutine add_angpair(ici,icj,nang_pair,iang_pair) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' + integer :: ici,icj,nang_pair,iang_pair(2,nres) + integer :: i,ian1,ian2 +! write (iout,*) "add_angpair: ici",ici," icj",icj, +! & " nang_pair",nang_pair + ian1=ici+2 + if (ian1.lt.4 .or. ian1.gt.nres) return + ian2=icj+2 +! write (iout,*) "ian1",ian1," ian2",ian2 + if (ian2.lt.4 .or. ian2.gt.nres) return + do i=1,nang_pair + if (ian1.eq.iang_pair(1,i) .and. ian2.eq.iang_pair(2,i)) return + enddo + nang_pair=nang_pair+1 + iang_pair(1,nang_pair)=ian1 + iang_pair(2,nang_pair)=ian2 + return + end subroutine add_angpair +!------------------------------------------------------------------------- + subroutine angnorm(jfrag,ishif1,ishif2,diffang_max,angn,fract,lprn) + + use geometry_data, only:nstart_sup,nend_sup,phi,theta,& + rad2deg,dwapi +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + real(kind=8) :: pinorm,deltang + logical :: lprn + integer :: jfrag,ishif1,ishif2,nn,npart,nn4,nne + real(kind=8) :: diffang_max,angn,fract,ff + integer :: i,j,nbeg,nend,ll,longest + if (lprn) write (iout,'(80(1h*))') + angn=0.0d0 + nn = 0 + fract = 1.0d0 + npart = npiece(jfrag,1) + nn4 = nstart_sup+3 + nne = min0(nend_sup,nres) + if (lprn) write (iout,*) "nn4",nn4," nne",nne + do i=1,npart + nbeg = ifrag(1,i,jfrag) + 3 - ishif1 + if (nbeg.lt.nn4) nbeg=nn4 + nend = ifrag(2,i,jfrag) + 1 - ishif2 + if (nend.gt.nne) nend=nne + if (nend.ge.nbeg) then + nn = nn + nend - nbeg + 1 + if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend,& + " nn",nn," ishift1",ishif1," ishift2",ishif2 + if (lprn) write (iout,*) "angles" + longest=0 + ll = 0 + do j=nbeg,nend +! deltang = pinorm(phi(j)-phi_ref(j+ishif1)) + deltang=spherang(phi_ref(j+ishif1),theta_ref(j-1+ishif1),& + theta_ref(j+ishif1),phi(j),theta(j-1),theta(j)) + if (dabs(deltang).gt.diffang_max) then + if (ll.gt.longest) longest = ll + ll = 0 + else + ll=ll+1 + endif + if (ll.gt.longest) longest = ll + if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j),& + rad2deg*phi_ref(j+ishif1),rad2deg*deltang + angn=angn+dabs(deltang) + enddo + longest=longest+3 + ff = dfloat(longest)/dfloat(nend - nbeg + 4) + if (lprn) write (iout,*)"segment",i," longest fragment within",& + diffang_max*rad2deg,":",longest," fraction",ff + if (ff.lt.fract) fract = ff + endif + enddo + if (nn.gt.0) then + angn = angn/nn + else + angn = dwapi + endif + if (lprn) write (iout,*) "nn",nn," norm",rad2deg*angn,& + " fract",fract + return + end subroutine angnorm +!------------------------------------------------------------------------- + subroutine angnorm2(jfrag,ishif1,ishif2,ncont,icont,lprn,& + diffang_max,anorm,fract) + + use geometry_data, only:nstart_sup,nend_sup,phi,theta,& + rad2deg +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + integer :: ncont,icont(2,ncont),longest + real(kind=8) :: anorm,diffang_max,fract + integer :: npiece_c,ifrag_c(2,maxpiece),ishift_c(maxpiece) + real(kind=8) :: pinorm + logical :: lprn + integer :: jfrag,ishif1,ishif2 + integer :: nn,nn4,nne,npart,i,j,jstart,jend,ic1,ic2,idi,iic + integer :: nbeg,nend,ll + real(kind=8) :: angn,ishifc,deltang,ff + + if (lprn) write (iout,'(80(1h*))') +! +! Determine the segments for which angles will be compared +! + nn4 = nstart_sup+3 + nne = min0(nend_sup,nres) + if (lprn) write (iout,*) "nn4",nn4," nne",nne + npart=npiece(jfrag,1) + npiece_c=0 + do i=1,npart +! write (iout,*) "i",i," ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) + if (icont(1,ncont).lt.ifrag(1,i,jfrag) .or. & + icont(1,1).gt.ifrag(2,i,jfrag)) goto 11 + jstart=1 + do while (jstart.lt.ncont .and. & + icont(1,jstart).lt.ifrag(1,i,jfrag)) +! write (iout,*) "jstart",jstart," icont",icont(1,jstart), +! & " ifrag",ifrag(1,i,jfrag) + jstart=jstart+1 + enddo +! write (iout,*) "jstart",jstart," icont",icont(1,jstart), +! & " ifrag",ifrag(1,i,jfrag) + if (icont(1,jstart).lt.ifrag(1,i,jfrag)) goto 11 + npiece_c=npiece_c+1 + ic1=icont(1,jstart) + ifrag_c(1,npiece_c)=icont(1,jstart) + jend=ncont + do while (jend.gt.1 .and. icont(1,jend).gt.ifrag(2,i,jfrag)) +! write (iout,*) "jend",jend," icont",icont(1,jend), +! & " ifrag",ifrag(2,i,jfrag) + jend=jend-1 + enddo +! write (iout,*) "jend",jend," icont",icont(1,jend), +! & " ifrag",ifrag(2,i,jfrag) + ic2=icont(1,jend) + ifrag_c(2,npiece_c)=icont(1,jend)+1 + ishift_c(npiece_c)=ishif1 +! write (iout,*) "1: i",i," jstart:",jstart," jend",jend, +! & " ic1",ic1," ic2",ic2, +! & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) + 11 continue + if (ncont.eq.1 .or. icont(2,ncont).gt.icont(2,1)) then + idi=1 + else + idi=-1 + endif +! write (iout,*) "idi",idi + if (idi.eq.1) then + if (icont(2,1).gt.ifrag(2,i,jfrag) .or. & + icont(2,ncont).lt.ifrag(1,i,jfrag)) goto 12 + jstart=1 + do while (jstart.lt.ncont .and. & + icont(2,jstart).lt.ifrag(1,i,jfrag)) +! write (iout,*) "jstart",jstart," icont",icont(2,jstart), +! & " ifrag",ifrag(1,i,jfrag) + jstart=jstart+1 + enddo +! write (iout,*) "jstart",jstart," icont",icont(2,jstart), +! & " ifrag",ifrag(1,i,jfrag) + if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 + npiece_c=npiece_c+1 + ic1=icont(2,jstart) + ifrag_c(2,npiece_c)=icont(2,jstart)+1 + jend=ncont + do while (jend.gt.1 .and. icont(2,jend).gt.ifrag(2,i,jfrag)) +! write (iout,*) "jend",jend," icont",icont(2,jend), +! & " ifrag",ifrag(2,i,jfrag) + jend=jend-1 + enddo +! write (iout,*) "jend",jend," icont",icont(2,jend), +! & " ifrag",ifrag(2,i,jfrag) + else if (idi.eq.-1) then + if (icont(2,ncont).gt.ifrag(2,i,jfrag) .or. & + icont(2,1).lt.ifrag(1,i,jfrag)) goto 12 + jstart=ncont + do while (jstart.gt.ncont .and. & + icont(2,jstart).lt.ifrag(1,i,jfrag)) +! write (iout,*) "jstart",jstart," icont",icont(2,jstart), +! & " ifrag",ifrag(1,i,jfrag) + jstart=jstart-1 + enddo +! write (iout,*) "jstart",jstart," icont",icont(2,jstart), +! & " ifrag",ifrag(1,i,jfrag) + if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 + npiece_c=npiece_c+1 + ic1=icont(2,jstart) + ifrag_c(2,npiece_c)=icont(2,jstart)+1 + jend=1 + do while (jend.lt.ncont .and. & + icont(2,jend).gt.ifrag(2,i,jfrag)) +! write (iout,*) "jend",jend," icont",icont(2,jend), +! & " ifrag",ifrag(2,i,jfrag) + jend=jend+1 + enddo +! write (iout,*) "jend",jend," icont",icont(2,jend), +! & " ifrag",ifrag(2,i,jfrag) + endif + ic2=icont(2,jend) + if (ic2.lt.ic1) then + iic = ic1 + ic1 = ic2 + ic2 = iic + endif +! write (iout,*) "2: i",i," ic1",ic1," ic2",ic2, +! & " jstart:",jstart," jend",jend, +! & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) + ifrag_c(1,npiece_c)=ic1 + ifrag_c(2,npiece_c)=ic2+1 + ishift_c(npiece_c)=ishif2 + 12 continue + enddo + if (lprn) then + write (iout,*) "Before merge: npiece_c",npiece_c + do i=1,npiece_c + write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) + enddo + endif +! +! Merge overlapping segments (e.g., avoid splitting helices) +! + i=1 + do while (i .lt. npiece_c) + if (ishift_c(i).eq.ishift_c(i+1) .and. & + ifrag_c(2,i).gt.ifrag_c(1,i+1)) then + ifrag_c(2,i)=ifrag_c(2,i+1) + do j=i+1,npiece_c + ishift_c(j)=ishift_c(j+1) + ifrag_c(1,j)=ifrag_c(1,j+1) + ifrag_c(2,j)=ifrag_c(2,j+1) + enddo + npiece_c=npiece_c-1 + else + i=i+1 + endif + enddo + if (lprn) then + write (iout,*) "After merge: npiece_c",npiece_c + do i=1,npiece_c + write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) + enddo + endif +! +! Compare angles +! + angn=0.0d0 + anorm=0 + nn = 0 + fract = 1.0d0 + npart = npiece_c + do i=1,npart + ishifc=ishift_c(i) + nbeg = ifrag_c(1,i) + 3 - ishifc + if (nbeg.lt.nn4) nbeg=nn4 + nend = ifrag_c(2,i) - ishifc + 1 + if (nend.gt.nne) nend=nne + if (nend.ge.nbeg) then + nn = nn + nend - nbeg + 1 + if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend,& + " nn",nn," ishifc",ishifc + if (lprn) write (iout,*) "angles" + longest=0 + ll = 0 + do j=nbeg,nend +! deltang = pinorm(phi(j)-phi_ref(j+ishifc)) + deltang=spherang(phi_ref(j+ishifc),theta_ref(j-1+ishifc),& + theta_ref(j+ishifc),phi(j),theta(j-1),theta(j)) + if (dabs(deltang).gt.diffang_max) then + if (ll.gt.longest) longest = ll + ll = 0 + else + ll=ll+1 + endif + if (ll.gt.longest) longest = ll + if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j),& + rad2deg*phi_ref(j+ishifc),rad2deg*deltang + angn=angn+dabs(deltang) + enddo + longest=longest+3 + ff = dfloat(longest)/dfloat(nend - nbeg + 4) + if (lprn) write (iout,*)"segment",i," longest fragment within",& + diffang_max*rad2deg,":",longest," fraction",ff + if (ff.lt.fract) fract = ff + endif + enddo + if (nn.gt.0) anorm = angn/nn + if (lprn) write (iout,*) "nn",nn," norm",anorm," fract:",fract + return + end subroutine angnorm2 +!------------------------------------------------------------------------- + real(kind=8) function angnorm1(nang_pair,iang_pair,lprn) + + use geometry_data, only:phi,theta,rad2deg +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + logical :: lprn + integer :: nang_pair,iang_pair(2,nres) + real(kind=8) :: pinorm + integer :: j,ia1,ia2 + real(kind=8) :: angn,deltang + angn=0.0d0 + if (lprn) write (iout,'(80(1h*))') + if (lprn) write (iout,*) "nang_pair",nang_pair + if (lprn) write (iout,*) "angles" + do j=1,nang_pair + ia1 = iang_pair(1,j) + ia2 = iang_pair(2,j) +! deltang = pinorm(phi(ia1)-phi_ref(ia2)) + deltang=spherang(phi_ref(ia2),theta_ref(ia2-1),& + theta_ref(ia2),phi(ia2),theta(ia2-1),theta(ia2)) + if (lprn) write (iout,'(3i5,3f10.5)')j,ia1,ia2,rad2deg*phi(ia1),& + rad2deg*phi_ref(ia2),rad2deg*deltang + angn=angn+dabs(deltang) + enddo + if (lprn) & + write (iout,*)"nang_pair",nang_pair," angn",rad2deg*angn/nang_pair + angnorm1 = angn/nang_pair + return + end function angnorm1 +!------------------------------------------------------------------------------ + subroutine angnorm12(diff) + + use geometry_data, only:phi,theta,nstart_sup,nend_sup +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.VAR' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' + real(kind=8) :: pinorm,diff + integer :: nn4,nne,j + diff=0.0d0 + nn4 = nstart_sup+3 + nne = min0(nend_sup,nres) +! do j=nn4-1,nne +! diff = diff+rad2deg*dabs(pinorm(theta(j)-theta_ref(j))) +! enddo + do j=nn4,nne +! diff = diff+rad2deg*dabs(pinorm(phi(j)-phi_ref(j))) + diff=diff+spherang(phi_ref(j),theta_ref(j-1),& + theta_ref(j),phi(j),theta(j-1),theta(j)) + enddo + return + end subroutine angnorm12 +!-------------------------------------------------------------------------------- + real(kind=8) function spherang(gam1,theta11,theta12,& + gam2,theta21,theta22) +! implicit none + use geometry, only:arcos + real(kind=8) :: gam1,theta11,theta12,gam2,theta21,theta22,& + x1,x2,xmed,f1,f2,fmed + real(kind=8) :: tolx=1.0d-4, tolf=1.0d-4 + real(kind=8) :: sumcos +!el real(kind=8) :: pinorm,sumangp !arcos, + integer :: it,maxit=100 +! Calculate the difference of the angles of two superposed 4-redidue fragments +! +! O P +! \ / +! O'--C--C +! \ +! P' +! +! The fragment O'-C-C-P' is rotated by angle fi about the C-C axis +! to achieve the minimum difference between the O'-C-O and P-C-P angles; +! the sum of these angles is the difference returned by the function. +! +! 4/28/04 AL +! If thetas match, take the difference of gamma and exit. + if (dabs(theta11-theta12).lt.tolx & + .and. dabs(theta21-theta22).lt.tolx) then + spherang=dabs(pinorm(gam2-gam1)) + return + endif +! If the gammas are the same, take the difference of thetas and exit. + x1=0.0d0 + x2=0.5d0*pinorm(gam2-gam1) + if (dabs(x2) .lt. tolx) then + spherang=dabs(theta11-theta21)+dabs(theta12-theta22) + return + else if (x2.lt.0.0d0) then + x1=x2 + x2=0.0d0 + endif +! Else apply regula falsi method to compute optimum overlap of the terminal Calphas + f1=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x1) + f2=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x2) + do it=1,maxit + xmed=x1-f1*(x2-x1)/(f2-f1) + fmed=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,xmed) +! write (*,*) 'it',it,' xmed ',xmed,' fmed ',fmed + if ( (dabs(xmed-x1).lt.tolx .or. dabs(x2-xmed).lt.tolx) & + .and. dabs(fmed).lt.tolf ) then + x1=xmed + f1=fmed + goto 10 + else if ( fmed*f1.lt.0.0d0 ) then + x2=xmed + f2=fmed + else + x1=xmed + f1=fmed + endif + enddo + 10 continue + spherang=arcos(dcos(theta11)*dcos(theta12) & + +dsin(theta11)*dsin(theta12)*dcos(x1))+ & + arcos(dcos(theta21)*dcos(theta22)+ & + dsin(theta21)*dsin(theta22)*dcos(gam2-gam1+x1)) + return + end function spherang +!-------------------------------------------------------------------------------- + real(kind=8) function sumangp(gam1,theta11,theta12,gam2,& + theta21,theta22,fi) +! implicit none + real(kind=8) :: gam1,theta11,theta12,gam2,theta21,theta22,fi,& + cost11,cost12,cost21,cost22,sint11,sint12,sint21,sint22,cosd1,& + cosd2 +! derivarive of the sum of the difference of the angles of a 4-residue fragment. +! real(kind=8) :: arcos + cost11=dcos(theta11) + cost12=dcos(theta12) + cost21=dcos(theta21) + cost22=dcos(theta22) + sint11=dsin(theta11) + sint12=dsin(theta12) + sint21=dsin(theta21) + sint22=dsin(theta22) + cosd1=cost11*cost12+sint11*sint12*dcos(fi) + cosd2=cost21*cost22+sint21*sint22*dcos(gam2-gam1+fi) + sumangp=sint11*sint12*dsin(fi)/dsqrt(1.0d0-cosd1*cosd1) & + +sint21*sint22*dsin(gam2-gam1+fi)/dsqrt(1.0d0-cosd2*cosd2) + return + end function sumangp +!----------------------------------------------------------------------------- +! contact.f +!----------------------------------------------------------------------------- + subroutine contact(lprint,ncont,icont,ist,ien) + + use calc_data + use geometry_data, only:c,dc,dc_norm + use energy_data, only:itype,maxcont +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' +! include 'COMMON.CALC' +! include 'COMMON.CONTPAR' +! include 'COMMON.LOCAL' + integer :: ist,ien,kkk,iti,itj,itypi,itypj,i1,i2,it1,it2 + real(kind=8) :: csc !el,dist + real(kind=8),dimension(maxcont) :: cscore,omt1,omt2,omt12,& + ddsc,ddla,ddlb + integer :: ncont + integer,dimension(2,maxcont) :: icont + real(kind=8) :: u,v,a(3),b(3),dla,dlb + logical :: lprint +!el------- + dla=0.0d0 + dlb=0.0d0 +!el------ + ncont=0 + kkk=3 + if (lprint) then + do i=1,nres + write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),& + c(3,i),dc(1,nres+i),dc(2,nres+i),dc(3,nres+i),& + dc_norm(1,nres+i),dc_norm(2,nres+i),dc_norm(3,nres+i) + enddo + endif + 110 format (a,'(',i3,')',9f8.3) + do i=ist,ien-kkk + iti=iabs(itype(i)) + if (iti.le.0 .or. iti.gt.ntyp) cycle + do j=i+kkk,ien + itj=iabs(itype(j)) + if (itj.le.0 .or. itj.gt.ntyp) cycle + itypi=iti + itypj=itj + xj = c(1,nres+j)-c(1,nres+i) + yj = c(2,nres+j)-c(2,nres+i) + zj = c(3,nres+j)-c(3,nres+i) + dxi = dc_norm(1,nres+i) + dyi = dc_norm(2,nres+i) + dzi = dc_norm(3,nres+i) + dxj = dc_norm(1,nres+j) + dyj = dc_norm(2,nres+j) + dzj = dc_norm(3,nres+j) + do k=1,3 + a(k)=dc(k,nres+i) + b(k)=dc(k,nres+j) + enddo +! write (iout,*) (a(k),k=1,3),(b(k),k=1,3) + if (icomparfunc.eq.1) then + call contfunc(csc,iti,itj) + else if (icomparfunc.eq.2) then + call scdist(csc,iti,itj) + else if (icomparfunc.eq.3 .or. icomparfunc.eq.5) then + csc = dist(nres+i,nres+j) + else if (icomparfunc.eq.4) then + call odlodc(c(1,i),c(1,j),a,b,u,v,dla,dlb,csc) + else + write (*,*) "Error - Unknown sidechain contact function" + write (iout,*) "Error - Unknown sidechain contact function" + endif + if (csc.lt.sc_cutoff(iti,itj)) then +! write(iout,*) "i",i," j",j," dla",dla,dsc(iti), +! & " dlb",dlb,dsc(itj)," csc",csc,sc_cutoff(iti,itj), +! & dxi,dyi,dzi,dxi**2+dyi**2+dzi**2, +! & dxj,dyj,dzj,dxj**2+dyj**2+dzj**2,om1,om2,om12, +! & xj,yj,zj +! write(iout,*)'egb',itypi,itypj,chi1,chi2,chip1,chip2, +! & sig0ij,rij,rrij,om1,om2,om12,chiom1,chiom2,chiom12, +! & chipom1,chipom2,chipom12,sig,eps2rt,rij_shift,e2,evdw, +! & csc + ncont=ncont+1 + cscore(ncont)=csc + icont(1,ncont)=i + icont(2,ncont)=j + omt1(ncont)=om1 + omt2(ncont)=om2 + omt12(ncont)=om12 + ddsc(ncont)=1.0d0/rij + ddla(ncont)=dla + ddlb(ncont)=dlb + 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,5f8.3,3f10.5)') & + i,restyp(it1),i1,restyp(it2),i2,cscore(i),& + sc_cutoff(iabs(it1),iabs(it2)),ddsc(i),ddla(i),ddlb(i),& + omt1(i),omt2(i),omt12(i) + enddo + endif + return + end subroutine contact +#else +!---------------------------------------------------------------------------- + subroutine contact(lprint,ncont,icont) + + use energy_data, only: nnt,nct,itype,ipot,maxcont,sigma,sigmaii +! 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,icont(2,maxcont) + logical :: lprint + integer :: kkk,i,j,i1,i2,it1,it2,iti,itj + real(kind=8) :: rcomp + ncont=0 + kkk=3 +! print *,'nnt=',nnt,' nct=',nct + do i=nnt+kkk,nct + iti=iabs(itype(i)) + do j=nnt,i-kkk + itj=iabs(itype(j)) + if (ipot.ne.4) then +! 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 + return + end subroutine contact +#endif +!---------------------------------------------------------------------------- + real(kind=8) function contact_fract(ncont,ncont_ref,& + icont,icont_ref) + + use energy_data, only:maxcont +! implicit none +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer :: i,j,nmatch + integer :: ncont,ncont_ref + integer,dimension(2,maxcont) :: icont,icont_ref + 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 +#ifndef CLUSTER +!------------------------------------------------------------------------------ + subroutine pept_cont(lprint,ncont,icont) + + use geometry_data, only:c + use energy_data, only:maxcont,nnt,nct,itype +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' + integer :: ncont,icont(2,maxcont) + integer :: i,j,k,kkk,i1,i2,it1,it2 + logical :: lprint +!el real(kind=8) :: dist + real(kind=8) :: rcomp=5.5d0 + ncont=0 + kkk=0 + print *,'Entering pept_cont: 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 + return + end subroutine pept_cont +!----------------------------------------------------------------------------- +! cont_frag.f +!----------------------------------------------------------------------------- + subroutine contacts_between_fragments(lprint,is,ncont,icont,& + ncont_interfrag,icont_interfrag) + + use energy_data, only:itype,maxcont +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.INTERACT' +! include 'COMMON.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.NAMES' + integer :: icont(2,maxcont),ncont_interfrag(mmaxfrag),& + icont_interfrag(2,maxcont,mmaxfrag) + logical :: OK1,OK2,lprint + integer :: is,ncont,i,j,ind,nc,k,ic1,ic2,l,i1,i2,it1,it2 +! Determine the contacts that occur within a fragment and between fragments. + do i=1,nfrag(1) + do j=1,i + ind = icant(i,j) + nc=0 +! write (iout,*) "i",i,(ifrag(1,k,i),ifrag(2,k,i) +! & ,k=1,npiece(i,1)) +! write (iout,*) "j",j,(ifrag(1,k,j),ifrag(2,k,j) +! & ,k=1,npiece(j,1)) +! write (iout,*) "ncont",ncont + do k=1,ncont + ic1=icont(1,k) + ic2=icont(2,k) + OK1=.false. + l=0 + do while (.not.OK1 .and. l.lt.npiece(j,1)) + l=l+1 + OK1=ic1.ge.ifrag(1,l,j)-is .and. & + ic1.le.ifrag(2,l,j)+is + enddo + OK2=.false. + l=0 + do while (.not.OK2 .and. l.lt.npiece(i,1)) + l=l+1 + OK2=ic2.ge.ifrag(1,l,i)-is .and. & + ic2.le.ifrag(2,l,i)+is + enddo +! write(iout,*) "k",k," ic1",ic1," ic2",ic2," OK1",OK1, +! & " OK2",OK2 + if (OK1.and.OK2) then + nc=nc+1 + icont_interfrag(1,nc,ind)=ic1 + icont_interfrag(2,nc,ind)=ic2 +! write (iout,*) "nc",nc," ic1",ic1," ic2",ic2 + endif + enddo + ncont_interfrag(ind)=nc +! do k=1,ncont_interfrag(ind) +! i1=icont_interfrag(1,k,ind) +! i2=icont_interfrag(2,k,ind) +! it1=itype(i1) +! it2=itype(i2) +! write (iout,'(i3,2x,a,i4,2x,a,i4)') +! & i,restyp(it1),i1,restyp(it2),i2 +! enddo + enddo + enddo + if (lprint) then + write (iout,*) "Contacts within fragments:" + do i=1,nfrag(1) + write (iout,*) "Fragment",i," (",(ifrag(1,k,i),& + ifrag(2,k,i),k=1,npiece(i,1)),")" + ind=icant(i,i) + do k=1,ncont_interfrag(ind) + i1=icont_interfrag(1,k,ind) + i2=icont_interfrag(2,k,ind) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') & + i,restyp(it1),i1,restyp(it2),i2 + enddo + enddo + write (iout,*) + write (iout,*) "Contacts between fragments:" + do i=1,nfrag(1) + do j=1,i-1 + ind = icant(i,j) + write (iout,*) "Fragments",i," (",(ifrag(1,k,i),& + ifrag(2,k,i),k=1,npiece(i,1)),") and",j," (",& + (ifrag(1,k,j),ifrag(2,k,j),k=1,npiece(j,1)),")" + write (iout,*) "Number of contacts",& + ncont_interfrag(ind) + ind=icant(i,j) + do k=1,ncont_interfrag(ind) + i1=icont_interfrag(1,k,ind) + i2=icont_interfrag(2,k,ind) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') & + i,restyp(it1),i1,restyp(it2),i2 + enddo + enddo + enddo + endif + return + end subroutine contacts_between_fragments +!----------------------------------------------------------------------------- +! contfunc.f +!----------------------------------------------------------------------------- + subroutine contfunc(cscore,itypi,itypj) +! +! This subroutine calculates the contact function based on +! the Gay-Berne potential of interaction. +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTPAR' +! include 'COMMON.CALC' + integer :: expon=6 + integer :: itypi,itypj + real(kind=8) :: cscore,sig0ij,rrij,sig,rij_shift,evdw,e2 +! + sig0ij=sig_comp(itypi,itypj) + chi1=chi_comp(itypi,itypj) + chi2=chi_comp(itypj,itypi) + chi12=chi1*chi2 + chip1=chip_comp(itypi,itypj) + chip2=chip_comp(itypj,itypi) + chip12=chip1*chip2 + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) +! Calculate angle-dependent terms of the contact function + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + chiom12=chi12*om12 +! print *,'egb',itypi,itypj,chi1,chi2,chip1,chip2, +! & sig0ij, +! & rij,rrij,om1,om2,om12 +! Calculate eps1(om12) + faceps1=1.0D0-om12*chiom12 + faceps1_inv=1.0D0/faceps1 + eps1=dsqrt(faceps1_inv) +! Following variable is eps1*deps1/dom12 + eps1_om12=faceps1_inv*chiom12 +! Calculate sigma(om1,om2,om12) + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 + sigsq=1.0D0-facsig*faceps1_inv +! Calculate eps2 and its derivatives in om1, om2, and om12. + chipom1=chip1*om1 + chipom2=chip2*om2 + chipom12=chip12*om12 + facp=1.0D0-om12*chipom12 + facp_inv=1.0D0/facp + facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 +! Following variable is the square root of eps2 + eps2rt=1.0D0-facp1*facp_inv + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij + if (rij_shift.le.0.0D0) then + evdw=1.0D1 + cscore = -dlog(evdw+1.0d-6) + return + endif + rij_shift=1.0D0/rij_shift + e2=(rij_shift*sig0ij)**expon + evdw=dabs(eps1*eps2rt**2*e2) + if (evdw.gt.1.0d1) evdw = 1.0d1 + cscore = -dlog(evdw+1.0d-6) + return + end subroutine contfunc +!------------------------------------------------------------------------------ + subroutine scdist(cscore,itypi,itypj) +! +! This subroutine calculates the contact distance +! + use calc_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CONTPAR' +! include 'COMMON.CALC' + integer :: itypi,itypj + real(kind=8) :: cscore,rrij + + chi1=chi_comp(itypi,itypj) + chi2=chi_comp(itypj,itypi) + chi12=chi1*chi2 + rrij=xj*xj+yj*yj+zj*zj + rij=dsqrt(rrij) +! Calculate angle-dependent terms of the contact function + erij(1)=xj/rij + erij(2)=yj/rij + erij(3)=zj/rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + chiom12=chi12*om12 + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + cscore=dsqrt(rrij+chi1**2+chi2**2+2*rij*(chiom2-chiom1)-2*chiom12) + return + end subroutine scdist +!------------------------------------------------------------------------------ +! elecont.f +!------------------------------------------------------------------------------ + subroutine elecont(lprint,ncont,icont,ist,ien) + + use geometry_data, only:c + use energy_data, only:maxcont,rpp,epp,itype,itel,vblinv,vblinv2 +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' +! include 'COMMON.LOCAL' + logical :: lprint + integer :: i,j,k,ist,ien,iteli,itelj,ind,i1,i2,it1,it2,ic1,ic2 + real(kind=8) :: rri,xi,yi,zi,dxi,dyi,dzi,xmedi,ymedi,zmedi,& + xj,yj,zj,dxj,dyj,dzj,aaa,bbb,ael6i,ael3i,rrmij,rmij,r3ij,r6ij,& + vrmij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,evdwij,el1,el2,& + eesij,ees,evdw,ene + real(kind=8),dimension(2,2) :: elpp6c=reshape((/-0.2379d0,& + -0.2056d0,-0.2056d0,-0.0610d0/),shape(elpp6c)) + real(kind=8),dimension(2,2) :: elpp3c=reshape((/ 0.0503d0,& + 0.0000d0, 0.0000d0, 0.0692d0/),shape(elpp3c)) + real(kind=8),dimension(2,2) :: ael6c,ael3c,appc,bppc + real(kind=8) :: elcutoff=-0.3d0 + real(kind=8) :: elecutoff_14=-0.5d0 + integer :: ncont,icont(2,maxcont) + real(kind=8) :: econt(maxcont) +! +! Load the constants of peptide bond - peptide bond interactions. +! Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. +! proline) - determined by averaging ECEPP energy. +! +! as of 7/06/91. +! +! data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ +! data rpp / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/ +!el data (elpp6c) /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/ +!el data (elpp3c) / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/ +!el data (elcutoff) /-0.3d0/ +!el data (elecutoff_14) /-0.5d0/ + ees=0.0d0 + evdw=0.0d0 + if (lprint) write (iout,'(a)') & + "Constants of electrostatic interaction energy expression." + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + appc(i,j)=epp(i,j)*rri*rri + bppc(i,j)=-2.0*epp(i,j)*rri + ael6c(i,j)=elpp6c(i,j)*4.2**6 + ael3c(i,j)=elpp3c(i,j)*4.2**3 + if (lprint) & + write (iout,'(2i2,4e15.4)') i,j,appc(i,j),bppc(i,j),ael6c(i,j),& + ael3c(i,j) + enddo + enddo + ncont=0 + do 1 i=ist,ien-2 + xi=c(1,i) + yi=c(2,i) + zi=c(3,i) + dxi=c(1,i+1)-c(1,i) + dyi=c(2,i+1)-c(2,i) + dzi=c(3,i+1)-c(3,i) + xmedi=xi+0.5*dxi + ymedi=yi+0.5*dyi + zmedi=zi+0.5*dzi + do 4 j=i+2,ien-1 + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + if (iteli.eq.2 .and. itelj.eq.2 & + .or.iteli.eq.0 .or.itelj.eq.0) goto 4 + aaa=appc(iteli,itelj) + bbb=bppc(iteli,itelj) + ael6i=ael6c(iteli,itelj) + ael3i=ael3c(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=ael6i*r6ij + fac4=ael3i*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 +!------------------------------------------------------------------------------ +! match_contact.f +!------------------------------------------------------------------------------ + subroutine match_contact(ishif1,ishif2,nc_match,nc_match1_max,& + ncont_ref,icont_ref,ncont,icont,jfrag,n_shif1,n_shif2,& + nc_frac,nc_req_set,istr,llocal,lprn) + + use energy_data, only:maxcont +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' + integer :: ncont_ref,ncont,ishift,ishif2,nc_match + integer,dimension(2,maxcont) :: icont_ref,icont !(2,maxcont) + real(kind=8) :: nc_frac + logical :: llocal,lprn + integer :: ishif1,nc_match1_max,jfrag,n_shif1,n_shif2,& + nc_req_set,istr,nc_match_max + integer :: i,nc_req,nc_match1,is,js + nc_match_max=0 + do i=1,ncont_ref + nc_match_max=nc_match_max+ & + min0(icont_ref(2,i)-icont_ref(1,i)-1,3) + enddo + if (istr.eq.3) then + nc_req=0 + else if (nc_req_set.eq.0) then + nc_req=nc_match_max*nc_frac + else + nc_req = dmin1(nc_match_max*nc_frac+0.5d0,& + dfloat(nc_req_set)+1.0d-7) + endif +! write (iout,*) "match_contact: nc_req:",nc_req +! write (iout,*) "nc_match_max",nc_match_max +! write (iout,*) "jfrag",jfrag," n_shif1",n_shif1, +! & " n_shif2",n_shif2 +! Match current contact map against reference contact map; exit, if at least +! half of the contacts match + call ncont_match(nc_match,nc_match1,0,0,ncont_ref,icont_ref,& + ncont,icont,jfrag,llocal,lprn) + nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",0,0," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. & + nc_req.eq.0 .and. nc_match.eq.1) then + ishif1=0 + ishif2=0 + return + endif +! If sufficient matches are not found, try to shift contact maps up to three +! positions. + if (n_shif1.gt.0) then + do is=1,n_shif1 +! The following four tries help to find shifted beta-sheet patterns +! Shift "left" strand backward + call ncont_match(nc_match,nc_match1,-is,0,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",-is,0," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. & + nc_req.eq.0 .and. nc_match.eq.1) then + ishif1=-is + ishif2=0 + return + endif +! Shift "left" strand forward + call ncont_match(nc_match,nc_match1,is,0,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",is,0," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. & + nc_req.eq.0 .and. nc_match.eq.1) then + ishif1=is + ishif2=0 + return + endif + enddo + if (nc_req.eq.0) return +! Shift "right" strand backward + do is=1,n_shif1 + call ncont_match(nc_match,nc_match1,0,-is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",0,-is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=0 + ishif2=-is + return + endif +! Shift "right" strand upward + call ncont_match(nc_match,nc_match1,0,is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",0,is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=0 + ishif2=is + return + endif + enddo ! is +! Now try to shift both residues in contacts. + do is=1,n_shif1 + do js=1,is + if (js.ne.is) then + call ncont_match(nc_match,nc_match1,-is,-js,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",-is,-js," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-is + ishif2=-js + return + endif + call ncont_match(nc_match,nc_match1,is,js,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",is,js," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=is + ishif2=js + return + endif +! + call ncont_match(nc_match,nc_match1,-js,-is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",-js,-is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-js + ishif2=-is + return + endif +! + call ncont_match(nc_match,nc_match1,js,is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",js,is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=js + ishif2=is + return + endif + endif +! + if (is+js.le.n_shif1) then + call ncont_match(nc_match,nc_match1,-is,js,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",-is,js," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-is + ishif2=js + return + endif +! + call ncont_match(nc_match,nc_match1,js,-is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",js,-is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=js + ishif2=-is + return + endif + endif +! + enddo !js + enddo !is + endif + + if (n_shif2.gt.0) then + do is=1,n_shif2 + call ncont_match(nc_match,nc_match1,-is,-is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",-is,-is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-is + ishif2=-is + return + endif + call ncont_match(nc_match,nc_match1,is,is,ncont_ref,& + icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) & + "Shift:",is,is," nc_match1",nc_match1,& + " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=is + ishif2=is + return + endif + enddo + endif +! If this point is reached, the contact maps are different. + nc_match=0 + ishif1=0 + ishif2=0 + return + end subroutine match_contact +!------------------------------------------------------------------------- + subroutine ncont_match(nc_match,nc_match1,ishif1,ishif2,& + ncont_ref,icont_ref,ncont,icont,jfrag,llocal,lprn) + + use energy_data, only:nnt,nct,maxcont +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.INTERACT' +! include 'COMMON.GEO' +! include 'COMMON.COMPAR' + logical :: llocal,lprn + integer ncont_ref,ncont,ishift,ishif2,nang_pair + integer,dimension(2,maxcont) :: icont_ref,icont,icont_match !(2,maxcont) + integer,dimension(2,nres) :: iang_pair !(2,maxres) + integer :: nc_match,nc_match1,ishif1,jfrag + integer :: i,j,ic1,ic2 + real(kind=8) :: diffang,fract,rad2deg + +! Compare the contact map against the reference contact map; they're stored +! in ICONT and ICONT_REF, respectively. The current contact map can be shifted. + if (lprn) write (iout,'(80(1h*))') + nc_match=0 + nc_match1=0 +! Check the local structure by comparing dihedral angles. +! write (iout,*) "ncont_match: ncont_ref",ncont_ref," llocal",llocal + if (llocal .and. ncont_ref.eq.0) then +! If there are no contacts just compare the dihedral angles and exit. + call angnorm(jfrag,ishif1,ishif2,ang_cut1(jfrag),diffang,fract,& + lprn) + if (lprn) write (iout,*) "diffang:",diffang*rad2deg,& + " ang_cut:",ang_cut(jfrag)*rad2deg," fract",fract + if (diffang.le.ang_cut(jfrag) .and. fract.ge.frac_min(jfrag)) & + then + nc_match=1 + else + nc_match=0 + endif + return + endif + nang_pair=0 + do i=1,ncont + ic1=icont(1,i)+ishif1 + ic2=icont(2,i)+ishif2 +! write (iout,*) "i",i," ic1",ic1," ic2",ic2 + if (ic1.lt.nnt .or. ic2.gt.nct) goto 10 + do j=1,ncont_ref + if (ic1.eq.icont_ref(1,j).and.ic2.eq.icont_ref(2,j)) then + nc_match=nc_match+min0(icont_ref(2,j)-icont_ref(1,j)-1,3) + nc_match1=nc_match1+1 + icont_match(1,nc_match1)=ic1 + icont_match(2,nc_match1)=ic2 +! call add_angpair(icont(1,i),icont_ref(1,j), +! & nang_pair,iang_pair) +! call add_angpair(icont(2,i),icont_ref(2,j), +! & nang_pair,iang_pair) + if (lprn) write (iout,*) "Contacts:",icont(1,i),icont(2,i),& + " match",icont_ref(1,j),icont_ref(2,j),& + " shifts",ishif1,ishif2 + goto 10 + endif + enddo + 10 continue + enddo + if (lprn) then + write (iout,*) "nc_match",nc_match," nc_match1",nc_match1 + write (iout,*) "icont_match" + do i=1,nc_match1 + write (iout,*) icont_match(1,i),icont_match(2,i) + enddo + endif + if (llocal .and. nc_match.gt.0) then + call angnorm2(jfrag,ishif1,ishif2,nc_match1,icont_match,lprn,& + ang_cut1(jfrag),diffang,fract) + if (lprn) write (iout,*) "diffang:",diffang*rad2deg,& + " ang_cut:",ang_cut(jfrag)*rad2deg,& + " ang_cut1",ang_cut1(jfrag)*rad2deg + if (diffang.gt.ang_cut(jfrag) & + .or. fract.lt.frac_min(jfrag)) nc_match=0 + endif +! if (nc_match.gt.0) then +! diffang = angnorm1(nang_pair,iang_pair,lprn) +! if (diffang.gt.ang_cut(jfrag)) nc_match=0 +! endif + if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2,& + " diffang",rad2deg*diffang," nc_match",nc_match + return + end subroutine ncont_match +!------------------------------------------------------------------------------ + subroutine match_secondary(jfrag,isecstr,nsec_match,lprn) +! This subroutine compares the secondary structure (isecstr) of fragment jfrag +! conformation considered to that of the reference conformation. +! Returns the number of equivalent residues (nsec_match). +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.PEPTCONT' +! include 'COMMON.COMPAR' + logical :: lprn + integer :: isecstr(nres) + integer :: jfrag,nsec_match,npart,i,j + npart = npiece(jfrag,1) + nsec_match=0 + if (lprn) then + write (iout,*) "match_secondary jfrag",jfrag," ifrag",& + (ifrag(1,i,jfrag),ifrag(2,i,jfrag),i=1,npart) + write (iout,'(80i1)') (isec_ref(j),j=1,nres) + write (iout,'(80i1)') (isecstr(j),j=1,nres) + endif + do i=1,npart + do j=ifrag(1,i,jfrag),ifrag(2,i,jfrag) +! The residue has equivalent conformational state to that of the reference +! structure, if: +! a) the conformational states are equal or +! b) the reference state is a coil and that of the conformation considered +! is a strand or +! c) the conformational state of the conformation considered is a strand +! and that of the reference conformation is a coil. +! 10/28/02 - case (b) deleted. + if (isecstr(j).eq.isec_ref(j) .or. & +! & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or. + isec_ref(j).eq.0 .and. isecstr(j).eq.1) & + nsec_match=nsec_match+1 + enddo + enddo + return + end subroutine match_secondary +!------------------------------------------------------------------------------ +! odlodc.f +!------------------------------------------------------------------------------ + subroutine odlodc(r1,r2,a,b,uu,vv,aa,bb,dd) + + use energy_data, only:ncont_ref,icont_ref!,nsccont_frag_ref,& +! isccont_frag_ref +! implicit real*8 (a-h,o-z) + real(kind=8),dimension(3) :: r1,r2,a,b,x,y + real(kind=8) :: uu,vv,aa,bb,dd + real(kind=8) :: ab,ar,br,det,dd1,dd2,dd3,dd4,dd5 +!el odl(u,v) = (r1(1)-r2(1))**2+(r1(2)-r2(2))**2+(r1(3)-r2(3))**2 & +!el + 2*ar*u - 2*br*v - 2*ab*u*v + aa*u**2 + bb*v**2 +! print *,"r1",(r1(i),i=1,3) +! print *,"r2",(r2(i),i=1,3) +! print *,"a",(a(i),i=1,3) +! print *,"b",(b(i),i=1,3) + aa = a(1)**2+a(2)**2+a(3)**2 + bb = b(1)**2+b(2)**2+b(3)**2 + ab = a(1)*b(1)+a(2)*b(2)+a(3)*b(3) + ar = a(1)*(r1(1)-r2(1))+a(2)*(r1(2)-r2(2))+a(3)*(r1(3)-r2(3)) + br = b(1)*(r1(1)-r2(1))+b(2)*(r1(2)-r2(2))+b(3)*(r1(3)-r2(3)) + det = aa*bb-ab**2 +! print *,'aa',aa,' bb',bb,' ab',ab,' ar',ar,' br',br,' det',det + uu = (-ar*bb+br*ab)/det + vv = (br*aa-ar*ab)/det +! print *,u,v + uu=dmin1(uu,1.0d0) + uu=dmax1(uu,0.0d0) + vv=dmin1(vv,1.0d0) + vv=dmax1(vv,0.0d0) +!el dd1 = odl(uu,vv) + dd1 = odl(uu,vv,r1,r2,ar,br,ab,aa,bb) +!el dd2 = odl(0.0d0,0.0d0) + dd2 = odl(0.0d0,0.0d0,r1,r2,ar,br,ab,aa,bb) +!el dd3 = odl(0.0d0,1.0d0) + dd3 = odl(0.0d0,1.0d0,r1,r2,ar,br,ab,aa,bb) +!el dd4 = odl(1.0d0,0.0d0) + dd4 = odl(1.0d0,0.0d0,r1,r2,ar,br,ab,aa,bb) +!el dd5 = odl(1.0d0,1.0d0) + dd5 = odl(1.0d0,1.0d0,r1,r2,ar,br,ab,aa,bb) + dd = dsqrt(dmin1(dd1,dd2,dd3,dd4,dd5)) + if (dd.eq.dd2) then + uu=0.0d0 + vv=0.0d0 + else if (dd.eq.dd3) then + uu=0.0d0 + vv=1.0d0 + else if (dd.eq.dd4) then + uu=1.0d0 + vv=0.0d0 + else if (dd.eq.dd5) then + uu=1.0d0 + vv=1.0d0 + endif +! Control check +! do i=1,3 +! x(i)=r1(i)+u*a(i) +! y(i)=r2(i)+v*b(i) +! enddo +! dd1 = (x(1)-y(1))**2+(x(2)-y(2))**2+(x(3)-y(3))**2 +! dd1 = dsqrt(dd1) + aa = dsqrt(aa) + bb = dsqrt(bb) +! write (8,*) uu,vv,dd,dd1 +! print *,dd,dd1 + return + end subroutine odlodc +!------------------------------------------------------------------------------ + real(kind=8) function odl(u,v,r1,r2,ar,br,ab,aa,bb) + + real(kind=8),dimension(3) :: r1,r2 + real(kind=8) :: aa,bb,u,v,ar,br,ab + + odl = (r1(1)-r2(1))**2+(r1(2)-r2(2))**2+(r1(3)-r2(3))**2 & + + 2*ar*u - 2*br*v - 2*ab*u*v + aa*u**2 + bb*v**2 + + end function odl +!------------------------------------------------------------------------------ +! proc_cont.f +!------------------------------------------------------------------------------ + subroutine proc_cont + + use geometry_data, only:rad2deg + use energy_data, only:ncont_ref,icont_ref!,nsccont_frag_ref,& +! isccont_frag_ref +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.HEADER' +! include 'COMMON.CONTACTS1' +! include 'COMMON.PEPTCONT' +! include 'COMMON.GEO' + integer :: i,j,k,ind,len_cut,ndigit,length_frag + + write (iout,*) "proc_cont: nlevel",nlevel + if (nlevel.lt.0) then + write (iout,*) "call define_fragments" + call define_fragments + else + write (iout,*) "call secondary2" + call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref,& + isec_ref) + endif + write (iout,'(80(1h=))') + write (iout,*) "Electrostatic contacts" + call contacts_between_fragments(.true.,0,ncont_pept_ref,& + icont_pept_ref,ncont_frag_ref(1),icont_frag_ref(1,1,1)) + write (iout,'(80(1h=))') + write (iout,*) "Side chain contacts" + call contacts_between_fragments(.true.,0,ncont_ref,& + icont_ref,nsccont_frag_ref(1),isccont_frag_ref(1,1,1)) + if (nlevel.lt.0) then + do i=1,nfrag(1) + ind=icant(i,i) + len_cut=1000 + if (istruct(i).le.1) then + len_cut=max0(len_frag(i,1)*4/5,3) + else if (istruct(i).eq.2 .or. istruct(i).eq.4) then + len_cut=max0(len_frag(i,1)*2/5,3) + endif + write (iout,*) "i",i," istruct",istruct(i)," ncont_frag",& + ncont_frag_ref(ind)," len_cut",len_cut,& + " icont_single",icont_single," iloc_single",iloc_single + iloc(i)=iloc_single + if (iloc(i).gt.0) write (iout,*) & + "Local structure used to compare structure of fragment",i,& + " to native." + if (istruct(i).ne.3 .and. istruct(i).ne.0 & + .and. icont_single.gt.0 .and. & + ncont_frag_ref(ind).ge.len_cut) then + write (iout,*) "Electrostatic contacts used to compare",& + " structure of fragment",i," to native." + ielecont(i,1)=1 + isccont(i,1)=0 + else if (icont_single.gt.0 .and. nsccont_frag_ref(ind) & + .ge.len_cut) then + write (iout,*) "Side chain contacts used to compare",& + " structure of fragment",i," to native." + isccont(i,1)=1 + ielecont(i,1)=0 + else + write (iout,*) "Contacts not used to compare",& + " structure of fragment",i," to native." + ielecont(i,1)=0 + isccont(i,1)=0 + nc_req_setf(i,1)=0 + endif + if (irms_single.gt.0 .or. isccont(i,1).eq.0 & + .and. ielecont(i,1).eq.0) then + write (iout,*) "RMSD used to compare",& + " structure of fragment",i," to native." + irms(i,1)=1 + else + write (iout,*) "RMSD not used to compare",& + " structure of fragment",i," to native." + irms(i,1)=0 + endif + enddo + endif + if (nlevel.lt.-1) then + call define_pairs + nlevel = -nlevel + if (nlevel.gt.3) nlevel=3 + if (nlevel.eq.3) then + nfrag(3)=1 + npiece(1,3)=nfrag(1) + do i=1,nfrag(1) + ipiece(i,1,3)=i + enddo + ielecont(1,3)=0 + isccont(1,3)=0 + irms(1,3)=1 + n_shift(1,1,3)=0 + n_shift(2,1,3)=0 + endif + else if (nlevel.eq.-1) then + nlevel=1 + endif + isnfrag(1)=0 + do i=1,nlevel + isnfrag(i+1)=isnfrag(i)+nfrag(i) + enddo + ndigit=3*nfrag(1) + do i=2,nlevel + ndigit=ndigit+2*nfrag(i) + enddo + write (iout,*) "ndigit",ndigit + if (.not.binary .and. ndigit.gt.30) then + write (iout,*) "Highest class too large; switching to",& + " binary representation." + binary=.true. + endif + write (iout,*) "isnfrag",(isnfrag(i),i=1,nlevel+1) + write(iout,*) "rmscut_base_up",rmscut_base_up,& + " rmscut_base_low",rmscut_base_low," rmsup_lim",rmsup_lim + do i=1,nlevel + do j=1,nfrag(i) + length_frag = 0 + if (i.eq.1) then + do k=1,npiece(j,i) + length_frag=length_frag+ifrag(2,k,j)-ifrag(1,k,j)+1 + enddo + else + do k=1,npiece(j,i) + length_frag=length_frag+len_frag(ipiece(k,j,i),1) + enddo + endif + len_frag(j,i)=length_frag + rmscutfrag(1,j,i)=rmscut_base_up*length_frag + rmscutfrag(2,j,i)=rmscut_base_low*length_frag + if (rmscutfrag(1,j,i).lt.rmsup_lim) & + rmscutfrag(1,j,i)=rmsup_lim + if (rmscutfrag(1,j,i).gt.rmsupup_lim) & + rmscutfrag(1,j,i)=rmsupup_lim + enddo + enddo + write (iout,*) "Level",1," number of fragments:",nfrag(1) + do j=1,nfrag(1) + write (iout,*) npiece(j,1),(ifrag(1,k,j),ifrag(2,k,j),& + k=1,npiece(j,1)),len_frag(j,1),rmscutfrag(1,j,1),& + rmscutfrag(2,j,1),n_shift(1,j,1),n_shift(2,j,1),& + ang_cut(j)*rad2deg,ang_cut1(j)*rad2deg,frac_min(j),& + nc_fragm(j,1),nc_req_setf(j,1),istruct(j) + enddo + do i=2,nlevel + write (iout,*) "Level",i," number of fragments:",nfrag(i) + do j=1,nfrag(i) + write (iout,*) npiece(j,i),(ipiece(k,j,i),& + k=1,npiece(j,i)),len_frag(j,i),rmscutfrag(1,j,i),& + rmscutfrag(2,j,i),n_shift(1,j,i),n_shift(2,j,i),& + nc_fragm(j,i),nc_req_setf(j,i) + enddo + enddo + return + end subroutine proc_cont +!------------------------------------------------------------------------------ +! define_pairs.f +!------------------------------------------------------------------------------ + subroutine define_pairs + +! use energy_data, only:nsccont_frag_ref +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.COMPAR' +! include 'COMMON.FRAG' +! include 'COMMON.CHAIN' +! include 'COMMON.HEADER' +! include 'COMMON.GEO' +! include 'COMMON.CONTACTS1' +! include 'COMMON.PEPTCONT' + integer :: j,k,i,length_frag,ind,ll1,ll2,len_cut + + do j=1,nfrag(1) + length_frag = 0 + do k=1,npiece(j,1) + length_frag=length_frag+ifrag(2,k,j)-ifrag(1,k,j)+1 + enddo + len_frag(j,1)=length_frag + write (iout,*) "Fragment",j," length",len_frag(j,1) + enddo + nfrag(2)=0 + do i=1,nfrag(1) + do j=i+1,nfrag(1) + ind = icant(i,j) + if (istruct(i).le.1 .or. istruct(j).le.1) then + if (istruct(i).le.1) then + ll1=len_frag(i,1) + else + ll1=len_frag(i,1)/2 + endif + if (istruct(j).le.1) then + ll2=len_frag(j,1) + else + ll2=len_frag(j,1)/2 + endif + len_cut=max0(min0(ll1*2/3,ll2*4/5),3) + else + if (istruct(i).eq.2 .or. istruct(i).eq.4) then + ll1=len_frag(i,1)/2 + else + ll1=len_frag(i,1) + endif + if (istruct(j).eq.2 .or. istruct(j).eq.4) then + ll2=len_frag(j,1)/2 + else + ll2=len_frag(j,1) + endif + len_cut=max0(min0(ll1*4/5,ll2)*4/5,3) + endif + write (iout,*) "Fragments",i,j," structure",istruct(i),& + istruct(j)," # contacts",& + ncont_frag_ref(ind),nsccont_frag_ref(ind),& + " lengths",len_frag(i,1),len_frag(j,1),& + " ll1",ll1," ll2",ll2," len_cut",len_cut + if ((istruct(i).eq.1 .or. istruct(j).eq.1) .and. & + nsccont_frag_ref(ind).ge.len_cut ) then + if (istruct(i).eq.1 .and. istruct(j).eq.1) then + write (iout,*) "Adding pair of helices",i,j,& + " based on SC contacts" + else + write (iout,*) "Adding helix+strand/sheet pair",i,j,& + " based on SC contacts" + endif + nfrag(2)=nfrag(2)+1 + if (icont_pair.gt.0) then + write (iout,*) "# SC contacts will be used",& + " in comparison." + isccont(nfrag(2),2)=1 + endif + if (irms_pair.gt.0) then + write (iout,*) "Fragment RMSD will be used",& + " in comparison." + irms(nfrag(2),2)=1 + endif + npiece(nfrag(2),2)=2 + ipiece(1,nfrag(2),2)=i + ipiece(2,nfrag(2),2)=j + ielecont(nfrag(2),2)=0 + n_shift(1,nfrag(2),2)=nshift_pair + n_shift(2,nfrag(2),2)=nshift_pair + nc_fragm(nfrag(2),2)=ncfrac_pair + nc_req_setf(nfrag(2),2)=ncreq_pair + else if ((istruct(i).ge.2 .and. istruct(i).le.4) & + .and. (istruct(j).ge.2 .and. istruct(i).le.4) & + .and. ncont_frag_ref(ind).ge.len_cut ) then + nfrag(2)=nfrag(2)+1 + write (iout,*) "Adding pair strands/sheets",i,j,& + " based on pp contacts" + if (icont_pair.gt.0) then + write (iout,*) "# pp contacts will be used",& + " in comparison." + ielecont(nfrag(2),2)=1 + endif + if (irms_pair.gt.0) then + write (iout,*) "Fragment RMSD will be used",& + " in comparison." + irms(nfrag(2),2)=1 + endif + npiece(nfrag(2),2)=2 + ipiece(1,nfrag(2),2)=i + ipiece(2,nfrag(2),2)=j + ielecont(nfrag(2),2)=1 + isccont(nfrag(2),2)=0 + n_shift(1,nfrag(2),2)=nshift_pair + n_shift(2,nfrag(2),2)=nshift_pair + nc_fragm(nfrag(2),2)=ncfrac_bet + nc_req_setf(nfrag(2),2)=ncreq_bet + endif + enddo + enddo + write (iout,*) "Pairs found" + do i=1,nfrag(2) + write (iout,*) ipiece(1,i,2),ipiece(2,i,2) + enddo + return + end subroutine define_pairs +!------------------------------------------------------------------------------ +! icant.f +!------------------------------------------------------------------------------ + INTEGER FUNCTION ICANT(I,J) + integer :: i,j + IF (I.GE.J) THEN + ICANT=(I*(I-1))/2+J + ELSE + ICANT=(J*(J-1))/2+I + ENDIF + RETURN + END FUNCTION ICANT +!------------------------------------------------------------------------------ +! mysort.f +!------------------------------------------------------------------------------ + subroutine imysort(n, m, mm, x, y, z, z1, z2, z3, z4, z5, z6) +! implicit none + integer :: n,m,mm + integer :: x(m,mm,n),y(n),z(n),z1(2,n),z6(n),xmin,xtemp + real(kind=8) :: z2(n),z3(n),z4(n),z5(n) + real(kind=8) :: xxtemp + integer :: i,j,k,imax + do i=1,n + xmin=x(1,1,i) + imax=i + do j=i+1,n + if (x(1,1,j).lt.xmin) then + imax=j + xmin=x(1,1,j) + endif + enddo + xxtemp=z2(imax) + z2(imax)=z2(i) + z2(i)=xxtemp + xxtemp=z3(imax) + z3(imax)=z3(i) + z3(i)=xxtemp + xxtemp=z4(imax) + z4(imax)=z4(i) + z4(i)=xxtemp + xxtemp=z5(imax) + z5(imax)=z5(i) + z5(i)=xxtemp + xtemp=y(imax) + y(imax)=y(i) + y(i)=xtemp + xtemp=z(imax) + z(imax)=z(i) + z(i)=xtemp + xtemp=z6(imax) + z6(imax)=z6(i) + z6(i)=xtemp + do j=1,2 + xtemp=z1(j,imax) + z1(j,imax)=z1(j,i) + z1(j,i)=xtemp + enddo + do j=1,m + do k=1,mm + xtemp=x(j,k,imax) + x(j,k,imax)=x(j,k,i) + x(j,k,i)=xtemp + enddo + enddo + enddo + return + end subroutine imysort +!------------------------------------------------------------------------------ +! qwolynes.f +!------------------------------------------------------------------------------- + real(kind=8) function qwolynes(ilevel,jfrag) + + use geometry_data, only:cref,nperm + use control_data, only:symetr + use energy_data, only:nnt,nct,itype +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTROL' + integer :: ilevel,jfrag,kkk + integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp + integer :: nsep=3 + real(kind=8),dimension(:),allocatable :: tempus !(maxperm) + real(kind=8) :: maxiQ !dist, + real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM + logical :: lprn=.false. + real(kind=8) :: x !el sigm +!el sigm(x)=0.25d0*x + nperm=1 + maxiQ=0 + do i=1,symetr + nperm=i*nperm + enddo +! write (iout,*) "QWolyes: " jfrag",jfrag, +! & " ilevel",ilevel + allocate(tempus(nperm)) + do kkk=1,nperm + qq = 0.0d0 + if (ilevel.eq.0) then + if (lprn) write (iout,*) "Q computed for whole molecule" + nl=0 + do il=nnt+nsep,nct + do jl=nnt,il-nsep + dij=0.0d0 + dijCM=0.0d0 + d0ij=0.0d0 + d0ijCM=0.0d0 + qqij=0.0d0 + qqijCM=0.0d0 + nl=nl+1 + d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & + (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & + (cref(3,jl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + if (lprn) then + write (iout,*) "il",il," jl",jl,& + " itype",itype(il),itype(jl) + write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM,& + " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM + endif + enddo + enddo + qq = qq/nl + if (lprn) write (iout,*) "nl",nl," qq",qq + else if (ilevel.eq.1) then + if (lprn) write (iout,*) "Level",ilevel," fragment",jfrag + nl=0 +! write (iout,*) "nlist_frag",nlist_frag(jfrag) + do i=2,nlist_frag(jfrag) + do j=1,i-1 + il=list_frag(i,jfrag) + jl=list_frag(j,jfrag) + if (iabs(il-jl).gt.nsep) then + dij=0.0d0 + dijCM=0.0d0 + d0ij=0.0d0 + d0ijCM=0.0d0 + qqij=0.0d0 + qqijCM=0.0d0 + nl=nl+1 + d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & + (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & + (cref(3,jl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + if (lprn) then + write (iout,*) "i",i," j",j," il",il," jl",jl,& + " itype",itype(il),itype(jl) + write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM,& + " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM + endif + endif + enddo + enddo + qq = qq/nl + if (lprn) write (iout,*) "nl",nl," qq",qq + else if (ilevel.eq.2) then + np=npiece(jfrag,ilevel) + nl=0 + do i=2,np + ip=ipiece(i,jfrag,ilevel) + do j=1,nlist_frag(ip) + il=list_frag(j,ip) + do k=1,i-1 + kp=ipiece(k,jfrag,ilevel) + do l=1,nlist_frag(kp) + kl=list_frag(l,kp) + if (iabs(kl-il).gt.nsep) then + nl=nl+1 + dij=0.0d0 + dijCM=0.0d0 + d0ij=0.0d0 + d0ijCM=0.0d0 + qqij=0.0d0 + qqijCM=0.0d0 + d0ij=dsqrt((cref(1,kl,kkk)-cref(1,il,kkk))**2+ & + (cref(2,kl,kkk)-cref(2,il,kkk))**2+ & + (cref(3,kl,kkk)-cref(3,il,kkk))**2) + dij=dist(il,kl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(kl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( & + (cref(1,kl+nres,kkk)-cref(1,il+nres,kkk))**2+ & + (cref(2,kl+nres,kkk)-cref(2,il+nres,kkk))**2+ & + (cref(3,kl+nres,kkk)-cref(3,il+nres,kkk))**2) + dijCM=dist(il+nres,kl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/ & + (sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + if (lprn) then + write (iout,*) "i",i," j",j," k",k," l",l," il",il,& + " kl",kl," itype",itype(il),itype(kl) + write (iout,*) " d0ij",d0ij," dij",dij," d0ijCM",& + d0ijCM," dijCM",dijCM," qqij",qqij," qqijCM",qqijCM + endif + endif + enddo ! l + enddo ! k + enddo ! j + enddo ! i + qq = qq/nl + if (lprn) write (iout,*) "nl",nl," qq",qq + else + write (iout,*)"Error: Q can be computed only for level 1 and 2." + endif + tempus(kkk)=qq + enddo + do kkk=1,nperm + if (maxiQ.le.tempus(kkk)) maxiQ=tempus(kkk) + enddo + qwolynes=1.0d0-maxiQ + deallocate(tempus) + return + end function qwolynes +!------------------------------------------------------------------------------- + real(kind=8) function sigm(x) + real(kind=8) :: x + sigm=0.25d0*x + return + end function sigm +!------------------------------------------------------------------------------- + subroutine fragment_list +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.COMPAR' + logical :: lprn=.true. + integer :: i,ilevel,j,k,jfrag + do jfrag=1,nfrag(1) + nlist_frag(jfrag)=0 + do i=1,npiece(jfrag,1) + if (lprn) write (iout,*) "jfrag=",jfrag,& + "i=",i," fragment",ifrag(1,i,jfrag),& + ifrag(2,i,jfrag) + do j=ifrag(1,i,jfrag),ifrag(2,i,jfrag) + do k=1,nlist_frag(jfrag) + if (list_frag(k,jfrag).eq.j) goto 10 + enddo + nlist_frag(jfrag)=nlist_frag(jfrag)+1 + list_frag(nlist_frag(jfrag),jfrag)=j + enddo + 10 continue + enddo + enddo + write (iout,*) "Fragment list" + do j=1,nfrag(1) + write (iout,*)"Fragment",j," list",(list_frag(k,j),& + k=1,nlist_frag(j)) + enddo + return + end subroutine fragment_list +!------------------------------------------------------------------------------- + real(kind=8) function rmscalc(ishif,i,j,jcon,lprn) + + use w_comm_local + use control_data, only:symetr + use geometry_data, only:nperm +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.CONTROL' + real(kind=8) :: przes(3),obrot(3,3) +!el real(kind=8) :: creff(3,nres*2),cc(3,nres*2) +!el logical :: iadded(nres) +!el integer :: inumber(2,nres) +!el common /ccc/ creff,cc,iadded,inumber + logical :: lprn + logical :: non_conv + integer :: ishif,i,j,jcon,idup,kkk,l,k,kk + real(kind=8) :: rminrms,rms + if (lprn) then + write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif + write (iout,*) "npiece",npiece(j,i) + call flush(iout) + endif +! write (iout,*) "symetr",symetr +! call flush(iout) + nperm=1 + do idup=1,symetr + nperm=nperm*idup + enddo +! write (iout,*) "nperm",nperm +! call flush(iout) + do kkk=1,nperm + idup=0 + do l=1,nres + iadded(l)=.false. + enddo +! write (iout,*) "kkk",kkk +! call flush(iout) + do k=1,npiece(j,i) + if (i.eq.1) then + if (lprn) then + write (iout,*) "Level 1: j=",j,"k=",k," adding fragment",& + ifrag(1,k,j),ifrag(2,k,j) + call flush(iout) + endif + call cprep(ifrag(1,k,j),ifrag(2,k,j),ishif,idup,kkk) +! write (iout,*) "Exit cprep" +! call flush(iout) +! write (iout,*) "ii=",ii + else + kk = ipiece(k,j,i) +! write (iout,*) "kk",kk," npiece",npiece(kk,1) + do l=1,npiece(kk,1) + if (lprn) then + write (iout,*) "Level",i,": j=",j,"k=",k," kk=",kk,& + " l=",l," adding fragment",& + ifrag(1,l,kk),ifrag(2,l,kk) + call flush(iout) + endif + call cprep(ifrag(1,l,kk),ifrag(2,l,kk),ishif,idup,kkk) +! write (iout,*) "After cprep" +! call flush(iout) + enddo + endif + enddo + enddo + if (lprn) then + write (iout,*) "tuszukaj" + do kkk=1,nperm + do k=1,idup + write(iout,'(5i4,2(3f10.5,5x))') i,j,k,inumber(1,k),& + inumber(2,k),(creff(l,k),l=1,3),(cc(l,k),l=1,3) + enddo + enddo + call flush(iout) + endif + rminrms=1.0d10 + do kkk=1,nperm + call fitsq(rms,cc(1,1),creff(1,1),idup,przes,obrot,non_conv) + if (non_conv) then + print *,'Error: FITSQ non-convergent, jcon',jcon,i + rms = 1.0d10 + else if (rms.lt.-1.0d-6) then + print *,'Error: rms^2 = ',rms,jcon,i + rms = 1.0d10 + else if (rms.ge.1.0d-6 .and. rms.lt.0) then + rms = 0.0d0 + endif +! write (iout,*) "rmsmin", rminrms, "rms", rms + if (rms.le.rminrms) rminrms=rms + enddo + rmscalc = dsqrt(rminrms) +! write (iout, *) "analysys", rmscalc,anatemp + return + end function rmscalc +!------------------------------------------------------------------------- + subroutine cprep(if1,if2,ishif,idup,kwa) + + use w_comm_local + use control_data, only:symetr + use geometry_data, only:nperm,cref,c +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' + real(kind=8) :: przes(3),obrot(3,3) +!el real(kind=8) :: creff(3,nres*2),cc(3,nres*2) +!el logical :: iadded(nres) +!el integer :: inumber(2,nres) + integer :: iistrart,kwa,blar +!el common /ccc/ creff,cc,iadded,inumber + integer :: if1,if2,ishif,idup,kkk,l,m +! write (iout,*) "Calling cprep symetr",symetr," kwa",kwa + nperm=1 + do blar=1,symetr + nperm=nperm*blar + enddo +! write (iout,*) "nperm",nperm + kkk=kwa +! ii=0 + do l=if1,if2 +! write (iout,*) "l",l," iadded",iadded(l) +! call flush(iout) + if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l)) & + then + idup=idup+1 + iadded(l)=.true. + inumber(1,idup)=l + inumber(2,idup)=l+ishif + do m=1,3 + creff(m,idup)=cref(m,l,kkk) + cc(m,idup)=c(m,l+ishif) + enddo + endif + enddo + return + end subroutine cprep +!------------------------------------------------------------------------- + real(kind=8) function rmsnat(jcon) + + use control_data, only:symetr + use geometry_data, only:nperm,cref,c + use energy_data, only:itype +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.CONTROL' + real(kind=8) :: przes(3),obrot(3,3),cc(3,2*nres),ccref(3,2*nres) + logical :: non_conv + integer :: ishif,i,j,resprzesun,jcon,kkk,nnsup + real(kind=8) :: rminrms,rmsminsing,rms + rminrms=10.0d10 + rmsminsing=10d10 + nperm=1 + do i=1,symetr + nperm=nperm*i + enddo + do kkk=1,nperm + nnsup=0 + do i=1,nres + if (itype(i).ne.ntyp1) then + nnsup=nnsup+1 + do j=1,3 + cc(j,nnsup)=c(j,i) + ccref(j,nnsup)=cref(j,i,kkk) + enddo + endif + enddo + call fitsq(rms,cc(1,1),ccref(1,1),nnsup,przes,obrot,non_conv) + if (non_conv) then + print *,'Error: FITSQ non-convergent, jcon',jcon,i + rms=1.0d10 + else if (rms.lt.-1.0d-6) then + print *,'Error: rms^2 = ',rms,jcon,i + rms = 1.0d10 + else if (rms.ge.1.0d-6 .and. rms.lt.0) then + rms=0.0d0 + endif + if (rms.le.rminrms) rminrms=rms +! write (iout,*) "kkk",kkk," rmsnat",rms , rminrms + enddo + rmsnat = dsqrt(rminrms) +! write (iout,*) "analysys",rmsnat, anatemp +! liczenie rmsdla pojedynczego lancucha + return + end function rmsnat +!------------------------------------------------------------------------------- + subroutine define_fragments + + use geometry_data, only:rad2deg + use energy_data, only:itype + use compare_data, only:nhfrag,nbfrag,bfrag,hfrag +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.FRAG' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.HEADER' +! include 'COMMON.GEO' +! include 'COMMON.CONTACTS' +! include 'COMMON.PEPTCONT' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' + integer :: nstrand,istrand(2,nres/2) + integer :: nhairp,ihairp(2,nres/5) + character(len=16) :: strstr(4)=reshape((/'helix','hairpin',& + 'strand','strand pair'/),shape(strstr)) + integer :: j,i,ii,i1,i2,i3,i4,it1,it2,it3,it4 + + write (iout,*) 'NC_FRAC_HEL',ncfrac_hel,' NC_REQ_HEL',ncreq_hel,& + 'NC_FRAC_BET',ncfrac_bet,' NC_REQ_BET',ncreq_bet,& + 'NC_FRAC_PAIR',ncfrac_pair,' NC_REQ_PAIR',ncreq_pair,& + ' RMS_PAIR',irms_pair,' SPLIT_BET',isplit_bet + write (iout,*) 'NSHIFT_HEL',nshift_hel,' NSHIFT_BET',nshift_bet,& + ' NSHIFT_STRAND',nshift_strand,' NSHIFT_PAIR',nshift_pair + write (iout,*) 'ANGCUT_HEL',angcut_hel*rad2deg,& + ' MAXANG_HEL',angcut1_hel*rad2deg + write (iout,*) 'ANGCUT_BET',angcut_bet*rad2deg,& + ' MAXANG_BET',angcut1_bet*rad2deg + write (iout,*) 'ANGCUT_STRAND',angcut_strand*rad2deg,& + ' MAXANG_STRAND',angcut1_strand*rad2deg + write (iout,*) 'FRAC_MIN',frac_min_set +! Find secondary structure elements (helices and beta-sheets) + call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref,& + isec_ref) +! Define primary fragments. First include the helices. + nhairp=0 + nstrand=0 +! Merge helices +! AL 12/23/03 - to avoid splitting helices into very small fragments + if (merge_helices) then + write (iout,*) "Before merging helices: nhfrag",nhfrag + do i=1,nhfrag + write (2,*) hfrag(1,i),hfrag(2,i) + enddo + i=1 + do while (i.lt.nhfrag) + if (hfrag(1,i+1)-hfrag(2,i).le.1) then + nhfrag=nhfrag-1 + hfrag(2,i)=hfrag(2,i+1) + do j=i+1,nhfrag + hfrag(1,j)=hfrag(1,j+1) + hfrag(2,j)=hfrag(2,j+1) + enddo + endif + i=i+1 + enddo + write (iout,*) "After merging helices: nhfrag",nhfrag + do i=1,nhfrag + write (2,*) hfrag(1,i),hfrag(2,i) + enddo + endif + nfrag(1)=nhfrag + do i=1,nhfrag + npiece(i,1)=1 + ifrag(1,1,i)=hfrag(1,i) + ifrag(2,1,i)=hfrag(2,i) + n_shift(1,i,1)=0 + n_shift(2,i,1)=nshift_hel + ang_cut(i)=angcut_hel + ang_cut1(i)=angcut1_hel + frac_min(i)=frac_min_set + nc_fragm(i,1)=ncfrac_hel + nc_req_setf(i,1)=ncreq_hel + istruct(i)=1 + enddo + write (iout,*) "isplit_bet",isplit_bet + if (isplit_bet.gt.1) then +! Split beta-sheets into strands and store strands as primary fragments. + call split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) + do i=1,nstrand + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=istrand(1,i) + ifrag(2,1,ii)=istrand(2,i) + n_shift(1,ii,1)=nshift_strand + n_shift(2,ii,1)=nshift_strand + ang_cut(ii)=angcut_strand + ang_cut1(ii)=angcut1_strand + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=0 + nc_req_setf(ii,1)=0 + istruct(ii)=3 + enddo + nfrag(1)=nfrag(1)+nstrand + else if (isplit_bet.eq.1) then +! Split only far beta-sheets; does not split hairpins. + call find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) + call split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) + do i=1,nhairp + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=ihairp(1,i) + ifrag(2,1,ii)=ihairp(2,i) + n_shift(1,ii,1)=nshift_bet + n_shift(2,ii,1)=nshift_bet + ang_cut(ii)=angcut_bet + ang_cut1(ii)=angcut1_bet + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=ncfrac_bet + nc_req_setf(ii,1)=ncreq_bet + istruct(ii)=2 + enddo + nfrag(1)=nfrag(1)+nhairp + do i=1,nstrand + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=istrand(1,i) + ifrag(2,1,ii)=istrand(2,i) + n_shift(1,ii,1)=nshift_strand + n_shift(2,ii,1)=nshift_strand + ang_cut(ii)=angcut_strand + ang_cut1(ii)=angcut1_strand + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=0 + nc_req_setf(ii,1)=0 + istruct(ii)=3 + enddo + nfrag(1)=nfrag(1)+nstrand + else +! Do not split beta-sheets; each pair of strands is a primary element. + call find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) + do i=1,nhairp + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=ihairp(1,i) + ifrag(2,1,ii)=ihairp(2,i) + n_shift(1,ii,1)=nshift_bet + n_shift(2,ii,1)=nshift_bet + ang_cut(ii)=angcut_bet + ang_cut1(ii)=angcut1_bet + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=ncfrac_bet + nc_req_setf(ii,1)=ncreq_bet + istruct(ii)=2 + enddo + nfrag(1)=nfrag(1)+nhairp + do i=1,nbfrag + ii=i+nfrag(1) + npiece(ii,1)=2 + ifrag(1,1,ii)=bfrag(1,i) + ifrag(2,1,ii)=bfrag(2,i) + if (bfrag(3,i).lt.bfrag(4,i)) then + ifrag(1,2,ii)=bfrag(3,i) + ifrag(2,2,ii)=bfrag(4,i) + else + ifrag(1,2,ii)=bfrag(4,i) + ifrag(2,2,ii)=bfrag(3,i) + endif + n_shift(1,ii,1)=nshift_bet + n_shift(2,ii,1)=nshift_bet + ang_cut(ii)=angcut_bet + ang_cut1(ii)=angcut1_bet + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=ncfrac_bet + nc_req_setf(ii,1)=ncreq_bet + istruct(ii)=4 + enddo + nfrag(1)=nfrag(1)+nbfrag + endif + write (iout,*) "The following primary fragments were found:" + write (iout,*) "Helices:",nhfrag + do i=1,nhfrag + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') & + i,restyp(it1),i1,restyp(it2),i2 + enddo + write (iout,*) "Hairpins:",nhairp + do i=nhfrag+1,nhfrag+nhairp + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,2x)') & + i,restyp(it1),i1,restyp(it2),i2 + enddo + write (iout,*) "Far strand pairs:",nbfrag + do i=nhfrag+nhairp+1,nhfrag+nhairp+nbfrag + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + i3=ifrag(1,2,i) + i4=ifrag(2,2,i) + it3=itype(i3) + it4=itype(i4) + write (iout,'(i3,2x,a,i4,2x,a,i4," and ",a,i4,2x,a,i4)') & + i,restyp(it1),i1,restyp(it2),i2,& + restyp(it3),i3,restyp(it4),i4 + enddo + write (iout,*) "Strands:",nstrand + do i=nhfrag+nhairp+nbfrag+1,nfrag(1) + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') & + i,restyp(it1),i1,restyp(it2),i2 + enddo + call imysort(nfrag(1),2,maxpiece,ifrag(1,1,1),npiece(1,1),& + istruct(1),n_shift(1,1,1),ang_cut(1),ang_cut1(1),frac_min(1),& + nc_fragm(1,1),nc_req_setf(1,1)) + write (iout,*) "Fragments after sorting:" + do i=1,nfrag(1) + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,$)') & + i,restyp(it1),i1,restyp(it2),i2 + if (npiece(i,1).eq.1) then + write (iout,'(2x,a)') strstr(istruct(i)) + else + i1=ifrag(1,2,i) + i2=ifrag(2,2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(2x,a,i4,2x,a,i4,2x,a)') & + restyp(it1),i1,restyp(it2),i2,strstr(istruct(i)) + endif + enddo + return + end subroutine define_fragments +!------------------------------------------------------------------------------ + subroutine find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' + integer :: nbfrag,bfrag(4,nres/3) + integer :: nhairp,ihairp(2,nres/5) + integer :: i,j,k + write (iout,*) "Entered find_and_remove_hairpins" + write (iout,*) "nbfrag",nbfrag + do i=1,nbfrag + write (iout,*) i,(bfrag(k,i),k=1,4) + enddo + nhairp=0 + i=1 + do while (i.le.nbfrag) + write (iout,*) "check hairpin:",i,(bfrag(j,i),j=1,4) + if (bfrag(3,i).gt.bfrag(4,i) .and. bfrag(4,i)-bfrag(2,i).lt.5) & + then + write (iout,*) "Found hairpin:",i,bfrag(1,i),bfrag(3,i) + nhairp=nhairp+1 + ihairp(1,nhairp)=bfrag(1,i) + ihairp(2,nhairp)=bfrag(3,i) + nbfrag=nbfrag-1 + do j=i,nbfrag + do k=1,4 + bfrag(k,j)=bfrag(k,j+1) + enddo + enddo + else + i=i+1 + endif + enddo + write (iout,*) "After finding hairpins:" + write (iout,*) "nhairp",nhairp + do i=1,nhairp + write (iout,*) i,ihairp(1,i),ihairp(2,i) + enddo + write (iout,*) "nbfrag",nbfrag + do i=1,nbfrag + write (iout,*) i,(bfrag(k,i),k=1,4) + enddo + return + end subroutine find_and_remove_hairpins +!------------------------------------------------------------------------------ + subroutine split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' + integer :: nbfrag,bfrag(4,nres/3) + integer :: nstrand,istrand(2,nres/2) + integer :: nhairp,ihairp(2,nres/5) + logical :: found + integer :: i,k + write (iout,*) "Entered split_beta" + write (iout,*) "nbfrag",nbfrag + do i=1,nbfrag + write (iout,*) i,(bfrag(k,i),k=1,4) + enddo + nstrand=0 + do i=1,nbfrag + write (iout,*) "calling add_strand:",i,bfrag(1,i),bfrag(2,i) + call add_strand(nstrand,istrand,nhairp,ihairp,& + bfrag(1,i),bfrag(2,i),found) + if (bfrag(3,i).lt.bfrag(4,i)) then + write (iout,*) "calling add_strand:",i,bfrag(3,i),bfrag(4,i) + call add_strand(nstrand,istrand,nhairp,ihairp,& + bfrag(3,i),bfrag(4,i),found) + else + write (iout,*) "calling add_strand:",i,bfrag(4,i),bfrag(3,i) + call add_strand(nstrand,istrand,nhairp,ihairp,& + bfrag(4,i),bfrag(3,i),found) + endif + enddo + nbfrag=0 + write (iout,*) "Strands found:",nstrand + do i=1,nstrand + write (iout,*) i,istrand(1,i),istrand(2,i) + enddo + return + end subroutine split_beta +!------------------------------------------------------------------------------ + subroutine add_strand(nstrand,istrand,nhairp,ihairp,is1,is2,found) +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'COMMON.IOUNITS' + integer :: nstrand,istrand(2,nres/2) + integer :: nhairp,ihairp(2,nres/5) + logical :: found + integer :: is1,is2,j,idelt + found=.false. + do j=1,nhairp + idelt=(ihairp(2,j)-ihairp(1,j))/6 + if (is1.lt.ihairp(2,j)-idelt.and.is2.gt.ihairp(1,j)+idelt) then + write (iout,*) "strand",is1,is2," is part of hairpin",& + ihairp(1,j),ihairp(2,j) + return + endif + enddo + do j=1,nstrand + idelt=(istrand(2,j)-istrand(1,j))/3 + if (is1.lt.istrand(2,j)-idelt.and.is2.gt.istrand(1,j)+idelt) & + then +! The strand already exists in the array; update its ends if necessary. + write (iout,*) "strand",is1,is2," found at position",j,& + ":",istrand(1,j),istrand(2,j) + istrand(1,j)=min0(istrand(1,j),is1) + istrand(2,j)=max0(istrand(2,j),is2) + return + endif + enddo +! The strand has not been found; add it to the array. + write (iout,*) "strand",is1,is2," added to the array." + found=.true. + nstrand=nstrand+1 + istrand(1,nstrand)=is1 + istrand(2,nstrand)=is2 + return + end subroutine add_strand +!------------------------------------------------------------------------------ + subroutine secondary2(lprint,lprint_sec,ncont,icont,isecstr) + + use geometry_data, only:anatemp,rad2deg,phi,nstart_sup,nend_sup + use energy_data, only:itype,maxcont + use compare_data, only:bfrag,hfrag,nbfrag,nhfrag + use compare, only:freeres +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'COMMON.IOUNITS' +! include 'COMMON.FRAG' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.CHAIN' +! include 'COMMON.NAMES' +! include 'COMMON.INTERACT' + integer :: ncont,icont(2,maxcont),isec(nres,4),nsec(nres),& + isecstr(nres) + logical :: lprint,lprint_sec,not_done !el,freeres + integer :: i,j,ii1,jj1,i1,j1,ij,k,ien,ist + integer :: nstrand,nbeta,nhelix,iii1,jjj1 + real(kind=8) :: p1,p2 +!rel external freeres + character(len=1) :: csec(0:2)=reshape((/'-','E','H'/),shape(csec)) + if (lprint) then + write (iout,*) "entered secondary2",ncont + write (iout,*) "nstart_sup",nstart_sup," nend_sup",nend_sup + do i=1,ncont + write (iout,*) icont(1,i),icont(2,i) + enddo + endif + do i=1,nres + isecstr(i)=0 + enddo + nbfrag=0 + nhfrag=0 + do i=1,nres + isec(i,1)=0 + isec(i,2)=0 + nsec(i)=0 + enddo + +! 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 (i1.ge.nstart_sup .and. i1.le.nend_sup & + .and. j1.gt.nstart_sup .and. j1.le.nend_sup) then +!d write (iout,*) "parallel",i1,j1 + 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_sec) 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 + endif ! i1.ge.nstart_sup .and. i1.le.nend_sup .and. i2.gt.nstart_sup .and. i2.le.nend_sup + enddo + +! 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) then + isec(ij,nsec(ij))=nbeta + endif + enddo + + + if (lprint_sec) 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 + +!d write (iout,*) "After beta:",nbfrag +!d do i=1,nbfrag +!d write (iout,*) (bfrag(j,i),j=1,4) +!d enddo + + if (nstrand.gt.0.and.lprint_sec) 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) + 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 write (iout,*) i1,j1,not_done,p1,p2 + 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)=j1 + + do ij=ii1,j1 + nsec(ij)=-1 + enddo + if (lprint_sec) 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_sec) 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_sec) then + write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" + write(12,'(a20)') "XMacStand ribbon.mac" + endif + + if (lprint) then + + write(iout,*) 'UNRES seq:',anatemp + 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),anatemp + enddo + + endif + + do j=1,nbfrag + do k=min0(bfrag(1,j),bfrag(2,j)),max0(bfrag(1,j),bfrag(2,j)) + isecstr(k)=1 + enddo + do k=min0(bfrag(3,j),bfrag(4,j)),max0(bfrag(3,j),bfrag(4,j)) + isecstr(k)=1 + enddo + enddo + do j=1,nhfrag + do k=hfrag(1,j),hfrag(2,j) + isecstr(k)=2 + enddo + enddo + if (lprint) then + write (iout,*) + write (iout,*) "Secondary structure" + do i=1,nres,80 + ist=i + ien=min0(i+79,nres) + write (iout,*) + write (iout,'(8(7x,i3))') (k,k=ist+9,ien,10) + write (iout,'(80a1)') (onelet(itype(k)),k=ist,ien) + write (iout,'(80a1)') (csec(isecstr(k)),k=ist,ien) + enddo + write (iout,*) + endif + return + end subroutine secondary2 +!------------------------------------------------- +! logical function freeres(i,j,nsec,isec) +! include 'DIMENSIONS' +! integer :: isec(nres,4),nsec(nres) +! integer :: i,j,k,l +! freeres=.false. +! +! 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 +!------------------------------------------------- + subroutine alloc_compar_arrays(nfrg,nlev) + + use energy_data, only:maxcont + use w_comm_local + integer :: nfrg,nlev + +!write(iout,*) "in alloc conpar arrays: nlevel=", nlevel," nfrag(1)=",nfrag(1) +!------------------------ +! commom.contacts +! common /contacts/ + allocate(nsccont_frag_ref(mmaxfrag)) !(mmaxfrag) !wham + allocate(isccont_frag_ref(2,maxcont,mmaxfrag)) !(2,maxcont,mmaxfrag) !wham +!------------------------ +! COMMON.COMPAR +! common /compar/ + allocate(rmsfrag(nfrg,nlev+1),nc_fragm(nfrg,nlev+1)) !(maxfrag,maxlevel) + allocate(qfrag(nfrg,2)) !(maxfrag,2) + allocate(rmscutfrag(2,nfrg,nlev+1)) !(2,maxfrag,maxlevel) + allocate(ang_cut(nfrg),ang_cut1(nfrg),frac_min(nfrg)) !(maxfrag) + allocate(nc_req_setf(nfrg,nlev+1),npiece(nfrg,nlev+1),& + ielecont(nfrg,nlev+1),isccont(nfrg,nlev+1),irms(nfrg,nlev+1),& + ishifft(nfrg,nlev+1),len_frag(nfrg,nlev+1)) !(maxfrag,maxlevel) + allocate(ncont_nat(2,nfrg,nlev+1)) + allocate(n_shift(2,nfrg,nlev+1)) !(2,maxfrag,maxlevel) +! allocate(nfrag(nlev)) !(maxlevel) + allocate(isnfrag(nlev+2)) !(maxlevel+1) + allocate(ifrag(2,maxpiece,nfrg)) !(2,maxpiece,maxfrag) + allocate(ipiece(maxpiece,nfrg,2:nlev+1)) !(maxpiece,maxfrag,2:maxlevel) + allocate(istruct(nfrg),iloc(nfrg),nlist_frag(nfrg)) !(maxfrag) + allocate(iclass(nlev*nfrg,nlev+1)) !(maxlevel*maxfrag,maxlevel) + allocate(list_frag(nres,nfrg)) !(maxres,maxfrag) +!------------------------ +! COMMON.PEPTCONT +! common /peptcont/ +! integer,dimension(:,:),allocatable :: icont_pept_ref !(2,maxcont) + allocate(ncont_frag_ref(mmaxfrag)) !(mmaxfrag) + allocate(icont_frag_ref(2,maxcont,mmaxfrag)) !(2,maxcont,mmaxfrag) +! integer,dimension(:),allocatable :: isec_ref !(maxres) +!------------------------ +! module w_comm_local +! common /ccc/ + allocate(creff(3,2*nres),cc(3,2*nres)) !(3,nres*2) + allocate(iadded(nres)) !(nres) + allocate(inumber(2,nres)) !(2,nres) + + +!------------------------------------------------------------------------------- + end subroutine alloc_compar_arrays +#endif +!------------------------------------------------------------------------------- + end module conform_compar + diff --git a/source/wham/conform_compar.f90 b/source/wham/conform_compar.f90 deleted file mode 100644 index 701e920..0000000 --- a/source/wham/conform_compar.f90 +++ /dev/null @@ -1,3559 +0,0 @@ - module conform_compar -!----------------------------------------------------------------------------- - use names - use io_units - use geometry_data, only:nres - use math, only:pinorm - use geometry, only:dist - use regularize_, only:fitsq -! - use wham_data -#ifndef CLUSTER - use w_compar_data -#endif -#ifdef MPI - use MPI_data -! include "COMMON.MPI" -#endif - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -#ifndef CLUSTER -!----------------------------------------------------------------------------- -! conf_compar.F -!----------------------------------------------------------------------------- - subroutine conf_compar(jcon,lprn,print_class) -! implicit real*8 (a-h,o-z) - use energy_data, only:icont,ncont,nnt,nct,maxcont!,& -! nsccont_frag_ref,isccont_frag_ref -#ifdef MPI - include "mpif.h" -#endif -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'DIMENSIONS.FREE' -! include 'COMMON.CONTROL' -! include 'COMMON.IOUNITS' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.PEPTCONT' -! include 'COMMON.CONTACTS1' -! include 'COMMON.HEADER' -! include 'COMMON.FREE' -! include 'COMMON.ENERGIES' -!#ifdef MPI -! include 'COMMON.MPI' -!#endif -! integer ilen -! external ilen - logical :: lprn,print_class - integer :: ncont_frag(mmaxfrag),& - icont_frag(2,maxcont,mmaxfrag),ncontsc,& - icontsc(1,maxcont),nsccont_frag(mmaxfrag),& - isccont_frag(2,maxcont,mmaxfrag) - integer :: isecstr(nres) - integer :: itemp(maxfrag) - character(len=4) :: liczba - real(kind=8) :: Epot,rms - integer :: jcon,i,j,ind,ncnat,nsec_match,ishift,ishif1,ishif2,& - nc_match,ncon_match,iclass_rms,ishifft_rms,ishiff,ishif - integer :: k,kk,iclass_con,iscor,ik,ishifft_con,idig,iex,im -! print *,"Enter conf_compar",jcon - call angnorm12(rmsang) -! Level 1: check secondary and supersecondary structure - call elecont(lprn,ncont,icont,nnt,nct) - if (lprn) then - write (iout,*) "elecont finished" - call flush(iout) - endif - call secondary2(lprn,.false.,ncont,icont,isecstr) - if (lprn) then - write (iout,*) "secondary2 finished" - call flush(iout) - endif - call contact(lprn,ncontsc,icontsc,nnt,nct) - if (lprn) then - write(iout,*) "Assigning electrostatic contacts" - call flush(iout) - endif - call contacts_between_fragments(lprn,3,ncont,icont,ncont_frag,& - icont_frag) - if (lprn) then - write(iout,*) "Assigning sidechain contacts" - call flush(iout) - endif - call contacts_between_fragments(lprn,3,ncontsc,icontsc,& - nsccont_frag,isccont_frag) - if (lprn) then - write(iout,*) "--> After contacts_between_fragments" - call flush(iout) - endif - do i=1,nlevel - do j=1,isnfrag(nlevel+1) - iclass(j,i)=0 - enddo - enddo - do j=1,nfrag(1) - ind = icant(j,j) - if (lprn) then - write (iout,'(80(1h=))') - write (iout,*) "Level",1," fragment",j - write (iout,'(80(1h=))') - endif - call flush(iout) - rmsfrag(j,1)=rmscalc(0,1,j,jcon,lprn) -! Compare electrostatic contacts in the current conf with that in the native -! structure. - if (lprn) write (iout,*) & - "Comparing electrostatic contact map and local structure" - call flush(iout) - ncnat=ncont_frag_ref(ind) -! write (iout,*) "before match_contact:",nc_fragm(j,1), -! & nc_req_setf(j,1) -! call flush(iout) - call match_secondary(j,isecstr,nsec_match,lprn) - if (lprn) write (iout,*) "Fragment",j," nsec_match",& - nsec_match," length",len_frag(j,1)," min_len",& - frac_sec*len_frag(j,1) - if (nsec_match.lt.frac_sec*len_frag(j,1)) then - iclass(j,1)=0 - if (lprn) write (iout,*) "Fragment",j,& - " has incorrect secondary structure" - else - iclass(j,1)=1 - if (lprn) write (iout,*) "Fragment",j,& - " has correct secondary structure" - endif - if (ielecont(j,1).gt.0) then - call match_contact(ishif1,ishif2,nc_match,ncon_match,& - ncont_frag_ref(ind),icont_frag_ref(1,1,ind),& - ncont_frag(ind),icont_frag(1,1,ind),& - j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1),& - nc_req_setf(j,1),istruct(j),.true.,lprn) - else if (isccont(j,1).gt.0) then - call match_contact(ishif1,ishif2,nc_match,ncon_match,& - nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind),& - nsccont_frag(ind),isccont_frag(1,1,ind),& - j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1),& - nc_req_setf(j,1),istruct(j),.true.,lprn) - else if (iloc(j).gt.0) then -! write (iout,*) "n_shif",n_shift(1,j,1),n_shift(2,j,1) - call match_contact(ishif1,ishif2,nc_match,ncon_match,& - 0,icont_frag_ref(1,1,ind),& - ncont_frag(ind),icont_frag(1,1,ind),& - j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1),& - 0,istruct(j),.true.,lprn) -! write (iout,*) "n_shif",n_shift(1,j,1),n_shift(2,j,1) - else - ishif=0 - nc_match=1 - endif - if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2 - ishif=ishif1 - qfrag(j,1)=qwolynes(1,j) - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (lprn) write (iout,*) "ishift",ishif," nc_match",nc_match -! write (iout,*) "j",j," ishif",ishif," rms",rmsfrag(j,1) - if (irms(j,1).gt.0) then - if (rmsfrag(j,1).le.rmscutfrag(1,j,1)) then - iclass_rms=2 - ishifft_rms=0 - else - ishiff=0 - rms=1.0d2 - iclass_rms=0 - do while (rms.gt.rmscutfrag(1,j,1) .and. & - ishiff.lt.n_shift(1,j,1)) - ishiff=ishiff+1 - rms=rmscalc(-ishiff,1,j,jcon,lprn) -! write(iout,*)"jcon,i,j,ishiff",jcon,i,j,-ishiff, -! & " rms",rms," rmscut",rmscutfrag(1,j,1) - if (lprn) write (iout,*) "rms",rmsfrag(j,1) - if (rms.gt.rmscutfrag(1,j,1)) then - rms=rmscalc(ishiff,1,j,jcon,lprn) -! write (iout,*) "jcon,1,j,ishiff",jcon,1,j,ishiff, -! & " rms",rms - endif - if (lprn) write (iout,*) "rms",rmsfrag(j,1) - enddo -! write (iout,*) "After loop: rms",rms, -! & " rmscut",rmscutfrag(1,j,1) -! write (iout,*) "iclass_rms",iclass_rms - if (rms.le.rmscutfrag(1,j,1)) then - ishifft_rms=ishiff - rmsfrag(j,1)=rms - iclass_rms=1 - endif -! write (iout,*) "iclass_rms",iclass_rms - endif -! write (iout,*) "ishif",ishif - if (iabs(ishifft_rms).gt.iabs(ishif)) ishif=ishifft_rms - else - iclass_rms=1 - endif -! write (iout,*) "ishif",ishif," iclass",iclass(j,1), -! & " iclass_rms",iclass_rms - if (nc_match.gt.0 .and. iclass_rms.gt.0) then - if (ishif.eq.0) then - iclass(j,1)=iclass(j,1)+6 - else - iclass(j,1)=iclass(j,1)+2 - endif - endif - ncont_nat(1,j,1)=nc_match - ncont_nat(2,j,1)=ncon_match - ishifft(j,1)=ishif -! write (iout,*) "iclass",iclass(j,1) - enddo -! Next levels: Check arrangements of elementary fragments. - do i=2,nlevel - do j=1,nfrag(i) - if (i .eq. 2) ind = icant(ipiece(1,j,i),ipiece(2,j,i)) - if (lprn) then - write (iout,'(80(1h=))') - write (iout,*) "Level",i," fragment",j - write (iout,'(80(1h=))') - endif -! If an elementary fragment doesn't exist, don't check higher hierarchy levels. - do k=1,npiece(j,i) - ik=ipiece(k,j,i) - if (iclass(ik,1).eq.0) then - iclass(j,i)=0 - goto 12 - endif - enddo - if (i.eq.2 .and. ielecont(j,i).gt.0) then - iclass_con=0 - ishifft_con=0 - if (lprn) write (iout,*) & - "Comparing electrostatic contact map: fragments",& - ipiece(1,j,i),ipiece(2,j,i)," ind",ind - call match_contact(ishif1,ishif2,nc_match,ncon_match,& - ncont_frag_ref(ind),icont_frag_ref(1,1,ind),& - ncont_frag(ind),icont_frag(1,1,ind),& - j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i),& - nc_req_setf(j,i),2,.false.,lprn) - ishif=ishif1 - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (nc_match.gt.0) then - if (ishif.eq.0) then - iclass_con=2 - else - iclass_con=1 - endif - endif - ncont_nat(1,j,i)=nc_match - ncont_nat(2,j,i)=ncon_match - ishifft_con=ishif - else if (i.eq.2 .and. isccont(j,i).gt.0) then - iclass_con=0 - ishifft_con=0 - if (lprn) write (iout,*) & - "Comparing sidechain contact map: fragments",& - ipiece(1,j,i),ipiece(2,j,i)," ind",ind - call match_contact(ishif1,ishif2,nc_match,ncon_match,& - nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind),& - nsccont_frag(ind),isccont_frag(1,1,ind),& - j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i),& - nc_req_setf(j,i),2,.false.,lprn) - ishif=ishif1 - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (nc_match.gt.0) then - if (ishif.eq.0) then - iclass_con=2 - else - iclass_con=1 - endif - endif - ncont_nat(1,j,i)=nc_match - ncont_nat(2,j,i)=ncon_match - ishifft_con=ishif - else if (i.eq.2) then - iclass_con=2 - ishifft_con=0 - endif - if (i.eq.2) qfrag(j,2)=qwolynes(2,j) - if (lprn) write (iout,*) & - "Comparing rms: fragments",& - (ipiece(k,j,i),k=1,npiece(j,i)) - rmsfrag(j,i)=rmscalc(0,i,j,jcon,lprn) - if (irms(j,i).gt.0) then - iclass_rms=0 - ishifft_rms=0 - if (lprn) write (iout,*) "rms",rmsfrag(j,i) -! write (iout,*) "i",i," j",j," rmsfrag",rmsfrag(j,i), -! & " rmscutfrag",rmscutfrag(1,j,i) - if (rmsfrag(j,i).le.rmscutfrag(1,j,i)) then - iclass_rms=2 - ishifft_rms=0 - else - ishif=0 - rms=1.0d2 - do while (rms.gt.rmscutfrag(1,j,i) .and. & - ishif.lt.n_shift(1,j,i)) - ishif=ishif+1 - rms=rmscalc(-ishif,i,j,jcon,lprn) -! print *,"jcon,i,j,ishif",jcon,i,j,-ishif," rms",rms - if (lprn) write (iout,*) "rms",rmsfrag(j,i) - if (rms.gt.rmscutfrag(1,j,i)) then - rms=rmscalc(ishif,i,j,jcon,lprn) -! print *,"jcon,i,j,ishif",jcon,i,j,ishif," rms",rms - endif - if (lprn) write (iout,*) "rms",rms - enddo - if (rms.le.rmscutfrag(1,j,i)) then - ishifft_rms=ishif - rmsfrag(j,i)=rms - iclass_rms=1 - endif - endif - endif - if (irms(j,i).eq.0 .and. ielecont(j,i).eq.0 .and. & - isccont(j,i).eq.0 ) then - write (iout,*) "Error: no measure of comparison specified:",& - " level",i," part",j - stop - endif - if (lprn) & - write (iout,*) "iclass_con",iclass_con," iclass_rms",iclass_rms - if (i.eq.2) then - iclass(j,i) = min0(iclass_con,iclass_rms) - if (iabs(ishifft_rms).gt.iabs(ishifft_con)) then - ishifft(j,i)=ishifft_rms - else - ishifft(j,i)=ishifft_con - endif - else if (i.gt.2) then - iclass(j,i) = iclass_rms - ishifft(j,i)= ishifft_rms - endif - 12 continue - enddo - enddo - rms_nat=rmsnat(jcon) - qnat=qwolynes(0,0) -! Compute the structural class - iscor=0 - IF (.NOT. BINARY) THEN - do i=1,nlevel - IF (I.EQ.1) THEN - do j=1,nfrag(i) - itemp(j)=iclass(j,i) - enddo - do kk=-1,1 - do j=1,nfrag(i) - idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-kk*nfrag(i)-j - iex = 2**idig - im=mod(itemp(j),2) - itemp(j)=itemp(j)/2 -! write (iout,*) "i",i," j",j," idig",idig," iex",iex, -! & " iclass",iclass(j,i)," im",im - iscor=iscor+im*iex - enddo - enddo - ELSE - do j=1,nfrag(i) - idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-j - iex = 2**idig - if (iclass(j,i).gt.0) then - im=1 - else - im=0 - endif -! write (iout,*) "i",i," j",j," idig",idig," iex",iex, -! & " iclass",iclass(j,i)," im",im - iscor=iscor+im*iex - enddo - do j=1,nfrag(i) - idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-nfrag(i)-j - iex = 2**idig - if (iclass(j,i).gt.1) then - im=1 - else - im=0 - endif -! write (iout,*) "i",i," j",j," idig",idig," iex",iex, -! & " iclass",iclass(j,i)," im",im - iscor=iscor+im*iex - enddo - ENDIF - enddo - iscore=iscor - ENDIF - if (print_class) then -#ifdef MPI - write(istat,'(i6,$)') jcon+indstart(me)-1 - write (istat,'(f10.2,$)') (potE(jcon,k),k=1,nParmSet),& - -entfac(jcon) -#else - write(istat,'(i6,$)') jcon - write (istat,'(f10.2,$)') (potE(jcon,k),k=1,nParmSet),& - -entfac(jcon) -#endif - write (istat,'(f8.3,2f6.3,$)') & - rms_nat,qnat,rmsang/(nres-3) - do j=1,nlevel - write(istat,'(1x,$,20(i3,$))') & - (ncont_nat(1,k,j),k=1,nfrag(j)) - if (j.lt.3) then - write(istat,'(1x,$,20(f5.1,f5.2$))') & - (rmsfrag(k,j),qfrag(k,j),k=1,nfrag(j)) - else - write(istat,'(1x,$,20(f5.1$))') & - (rmsfrag(k,j),k=1,nfrag(j)) - endif - write(istat,'(1x,$,20(i1,$))') & - (iclass(k,j),k=1,nfrag(j)) - enddo - if (binary) then - write (istat,'(" ",$)') - do j=1,nlevel - write (istat,'(100(i1,$))')(iclass(k,j),& - k=1,nfrag(j)) - if (j.lt.nlevel) write(iout,'(".",$)') - enddo - write (istat,*) - else - write (istat,'(i10)') iscore - endif - endif - RETURN - END subroutine conf_compar -!----------------------------------------------------------------------------- -! angnorm.f -!----------------------------------------------------------------------------- - subroutine add_angpair(ici,icj,nang_pair,iang_pair) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' - integer :: ici,icj,nang_pair,iang_pair(2,nres) - integer :: i,ian1,ian2 -! write (iout,*) "add_angpair: ici",ici," icj",icj, -! & " nang_pair",nang_pair - ian1=ici+2 - if (ian1.lt.4 .or. ian1.gt.nres) return - ian2=icj+2 -! write (iout,*) "ian1",ian1," ian2",ian2 - if (ian2.lt.4 .or. ian2.gt.nres) return - do i=1,nang_pair - if (ian1.eq.iang_pair(1,i) .and. ian2.eq.iang_pair(2,i)) return - enddo - nang_pair=nang_pair+1 - iang_pair(1,nang_pair)=ian1 - iang_pair(2,nang_pair)=ian2 - return - end subroutine add_angpair -!------------------------------------------------------------------------- - subroutine angnorm(jfrag,ishif1,ishif2,diffang_max,angn,fract,lprn) - - use geometry_data, only:nstart_sup,nend_sup,phi,theta,& - rad2deg,dwapi -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - real(kind=8) :: pinorm,deltang - logical :: lprn - integer :: jfrag,ishif1,ishif2,nn,npart,nn4,nne - real(kind=8) :: diffang_max,angn,fract,ff - integer :: i,j,nbeg,nend,ll,longest - if (lprn) write (iout,'(80(1h*))') - angn=0.0d0 - nn = 0 - fract = 1.0d0 - npart = npiece(jfrag,1) - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) - if (lprn) write (iout,*) "nn4",nn4," nne",nne - do i=1,npart - nbeg = ifrag(1,i,jfrag) + 3 - ishif1 - if (nbeg.lt.nn4) nbeg=nn4 - nend = ifrag(2,i,jfrag) + 1 - ishif2 - if (nend.gt.nne) nend=nne - if (nend.ge.nbeg) then - nn = nn + nend - nbeg + 1 - if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend,& - " nn",nn," ishift1",ishif1," ishift2",ishif2 - if (lprn) write (iout,*) "angles" - longest=0 - ll = 0 - do j=nbeg,nend -! deltang = pinorm(phi(j)-phi_ref(j+ishif1)) - deltang=spherang(phi_ref(j+ishif1),theta_ref(j-1+ishif1),& - theta_ref(j+ishif1),phi(j),theta(j-1),theta(j)) - if (dabs(deltang).gt.diffang_max) then - if (ll.gt.longest) longest = ll - ll = 0 - else - ll=ll+1 - endif - if (ll.gt.longest) longest = ll - if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j),& - rad2deg*phi_ref(j+ishif1),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - longest=longest+3 - ff = dfloat(longest)/dfloat(nend - nbeg + 4) - if (lprn) write (iout,*)"segment",i," longest fragment within",& - diffang_max*rad2deg,":",longest," fraction",ff - if (ff.lt.fract) fract = ff - endif - enddo - if (nn.gt.0) then - angn = angn/nn - else - angn = dwapi - endif - if (lprn) write (iout,*) "nn",nn," norm",rad2deg*angn,& - " fract",fract - return - end subroutine angnorm -!------------------------------------------------------------------------- - subroutine angnorm2(jfrag,ishif1,ishif2,ncont,icont,lprn,& - diffang_max,anorm,fract) - - use geometry_data, only:nstart_sup,nend_sup,phi,theta,& - rad2deg -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - integer :: ncont,icont(2,ncont),longest - real(kind=8) :: anorm,diffang_max,fract - integer :: npiece_c,ifrag_c(2,maxpiece),ishift_c(maxpiece) - real(kind=8) :: pinorm - logical :: lprn - integer :: jfrag,ishif1,ishif2 - integer :: nn,nn4,nne,npart,i,j,jstart,jend,ic1,ic2,idi,iic - integer :: nbeg,nend,ll - real(kind=8) :: angn,ishifc,deltang,ff - - if (lprn) write (iout,'(80(1h*))') -! -! Determine the segments for which angles will be compared -! - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) - if (lprn) write (iout,*) "nn4",nn4," nne",nne - npart=npiece(jfrag,1) - npiece_c=0 - do i=1,npart -! write (iout,*) "i",i," ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - if (icont(1,ncont).lt.ifrag(1,i,jfrag) .or. & - icont(1,1).gt.ifrag(2,i,jfrag)) goto 11 - jstart=1 - do while (jstart.lt.ncont .and. & - icont(1,jstart).lt.ifrag(1,i,jfrag)) -! write (iout,*) "jstart",jstart," icont",icont(1,jstart), -! & " ifrag",ifrag(1,i,jfrag) - jstart=jstart+1 - enddo -! write (iout,*) "jstart",jstart," icont",icont(1,jstart), -! & " ifrag",ifrag(1,i,jfrag) - if (icont(1,jstart).lt.ifrag(1,i,jfrag)) goto 11 - npiece_c=npiece_c+1 - ic1=icont(1,jstart) - ifrag_c(1,npiece_c)=icont(1,jstart) - jend=ncont - do while (jend.gt.1 .and. icont(1,jend).gt.ifrag(2,i,jfrag)) -! write (iout,*) "jend",jend," icont",icont(1,jend), -! & " ifrag",ifrag(2,i,jfrag) - jend=jend-1 - enddo -! write (iout,*) "jend",jend," icont",icont(1,jend), -! & " ifrag",ifrag(2,i,jfrag) - ic2=icont(1,jend) - ifrag_c(2,npiece_c)=icont(1,jend)+1 - ishift_c(npiece_c)=ishif1 -! write (iout,*) "1: i",i," jstart:",jstart," jend",jend, -! & " ic1",ic1," ic2",ic2, -! & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - 11 continue - if (ncont.eq.1 .or. icont(2,ncont).gt.icont(2,1)) then - idi=1 - else - idi=-1 - endif -! write (iout,*) "idi",idi - if (idi.eq.1) then - if (icont(2,1).gt.ifrag(2,i,jfrag) .or. & - icont(2,ncont).lt.ifrag(1,i,jfrag)) goto 12 - jstart=1 - do while (jstart.lt.ncont .and. & - icont(2,jstart).lt.ifrag(1,i,jfrag)) -! write (iout,*) "jstart",jstart," icont",icont(2,jstart), -! & " ifrag",ifrag(1,i,jfrag) - jstart=jstart+1 - enddo -! write (iout,*) "jstart",jstart," icont",icont(2,jstart), -! & " ifrag",ifrag(1,i,jfrag) - if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 - npiece_c=npiece_c+1 - ic1=icont(2,jstart) - ifrag_c(2,npiece_c)=icont(2,jstart)+1 - jend=ncont - do while (jend.gt.1 .and. icont(2,jend).gt.ifrag(2,i,jfrag)) -! write (iout,*) "jend",jend," icont",icont(2,jend), -! & " ifrag",ifrag(2,i,jfrag) - jend=jend-1 - enddo -! write (iout,*) "jend",jend," icont",icont(2,jend), -! & " ifrag",ifrag(2,i,jfrag) - else if (idi.eq.-1) then - if (icont(2,ncont).gt.ifrag(2,i,jfrag) .or. & - icont(2,1).lt.ifrag(1,i,jfrag)) goto 12 - jstart=ncont - do while (jstart.gt.ncont .and. & - icont(2,jstart).lt.ifrag(1,i,jfrag)) -! write (iout,*) "jstart",jstart," icont",icont(2,jstart), -! & " ifrag",ifrag(1,i,jfrag) - jstart=jstart-1 - enddo -! write (iout,*) "jstart",jstart," icont",icont(2,jstart), -! & " ifrag",ifrag(1,i,jfrag) - if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 - npiece_c=npiece_c+1 - ic1=icont(2,jstart) - ifrag_c(2,npiece_c)=icont(2,jstart)+1 - jend=1 - do while (jend.lt.ncont .and. & - icont(2,jend).gt.ifrag(2,i,jfrag)) -! write (iout,*) "jend",jend," icont",icont(2,jend), -! & " ifrag",ifrag(2,i,jfrag) - jend=jend+1 - enddo -! write (iout,*) "jend",jend," icont",icont(2,jend), -! & " ifrag",ifrag(2,i,jfrag) - endif - ic2=icont(2,jend) - if (ic2.lt.ic1) then - iic = ic1 - ic1 = ic2 - ic2 = iic - endif -! write (iout,*) "2: i",i," ic1",ic1," ic2",ic2, -! & " jstart:",jstart," jend",jend, -! & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - ifrag_c(1,npiece_c)=ic1 - ifrag_c(2,npiece_c)=ic2+1 - ishift_c(npiece_c)=ishif2 - 12 continue - enddo - if (lprn) then - write (iout,*) "Before merge: npiece_c",npiece_c - do i=1,npiece_c - write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) - enddo - endif -! -! Merge overlapping segments (e.g., avoid splitting helices) -! - i=1 - do while (i .lt. npiece_c) - if (ishift_c(i).eq.ishift_c(i+1) .and. & - ifrag_c(2,i).gt.ifrag_c(1,i+1)) then - ifrag_c(2,i)=ifrag_c(2,i+1) - do j=i+1,npiece_c - ishift_c(j)=ishift_c(j+1) - ifrag_c(1,j)=ifrag_c(1,j+1) - ifrag_c(2,j)=ifrag_c(2,j+1) - enddo - npiece_c=npiece_c-1 - else - i=i+1 - endif - enddo - if (lprn) then - write (iout,*) "After merge: npiece_c",npiece_c - do i=1,npiece_c - write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) - enddo - endif -! -! Compare angles -! - angn=0.0d0 - anorm=0 - nn = 0 - fract = 1.0d0 - npart = npiece_c - do i=1,npart - ishifc=ishift_c(i) - nbeg = ifrag_c(1,i) + 3 - ishifc - if (nbeg.lt.nn4) nbeg=nn4 - nend = ifrag_c(2,i) - ishifc + 1 - if (nend.gt.nne) nend=nne - if (nend.ge.nbeg) then - nn = nn + nend - nbeg + 1 - if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend,& - " nn",nn," ishifc",ishifc - if (lprn) write (iout,*) "angles" - longest=0 - ll = 0 - do j=nbeg,nend -! deltang = pinorm(phi(j)-phi_ref(j+ishifc)) - deltang=spherang(phi_ref(j+ishifc),theta_ref(j-1+ishifc),& - theta_ref(j+ishifc),phi(j),theta(j-1),theta(j)) - if (dabs(deltang).gt.diffang_max) then - if (ll.gt.longest) longest = ll - ll = 0 - else - ll=ll+1 - endif - if (ll.gt.longest) longest = ll - if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j),& - rad2deg*phi_ref(j+ishifc),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - longest=longest+3 - ff = dfloat(longest)/dfloat(nend - nbeg + 4) - if (lprn) write (iout,*)"segment",i," longest fragment within",& - diffang_max*rad2deg,":",longest," fraction",ff - if (ff.lt.fract) fract = ff - endif - enddo - if (nn.gt.0) anorm = angn/nn - if (lprn) write (iout,*) "nn",nn," norm",anorm," fract:",fract - return - end subroutine angnorm2 -!------------------------------------------------------------------------- - real(kind=8) function angnorm1(nang_pair,iang_pair,lprn) - - use geometry_data, only:phi,theta,rad2deg -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - logical :: lprn - integer :: nang_pair,iang_pair(2,nres) - real(kind=8) :: pinorm - integer :: j,ia1,ia2 - real(kind=8) :: angn,deltang - angn=0.0d0 - if (lprn) write (iout,'(80(1h*))') - if (lprn) write (iout,*) "nang_pair",nang_pair - if (lprn) write (iout,*) "angles" - do j=1,nang_pair - ia1 = iang_pair(1,j) - ia2 = iang_pair(2,j) -! deltang = pinorm(phi(ia1)-phi_ref(ia2)) - deltang=spherang(phi_ref(ia2),theta_ref(ia2-1),& - theta_ref(ia2),phi(ia2),theta(ia2-1),theta(ia2)) - if (lprn) write (iout,'(3i5,3f10.5)')j,ia1,ia2,rad2deg*phi(ia1),& - rad2deg*phi_ref(ia2),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - if (lprn) & - write (iout,*)"nang_pair",nang_pair," angn",rad2deg*angn/nang_pair - angnorm1 = angn/nang_pair - return - end function angnorm1 -!------------------------------------------------------------------------------ - subroutine angnorm12(diff) - - use geometry_data, only:phi,theta,nstart_sup,nend_sup -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.GEO' - real(kind=8) :: pinorm,diff - integer :: nn4,nne,j - diff=0.0d0 - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) -! do j=nn4-1,nne -! diff = diff+rad2deg*dabs(pinorm(theta(j)-theta_ref(j))) -! enddo - do j=nn4,nne -! diff = diff+rad2deg*dabs(pinorm(phi(j)-phi_ref(j))) - diff=diff+spherang(phi_ref(j),theta_ref(j-1),& - theta_ref(j),phi(j),theta(j-1),theta(j)) - enddo - return - end subroutine angnorm12 -!-------------------------------------------------------------------------------- - real(kind=8) function spherang(gam1,theta11,theta12,& - gam2,theta21,theta22) -! implicit none - use geometry, only:arcos - real(kind=8) :: gam1,theta11,theta12,gam2,theta21,theta22,& - x1,x2,xmed,f1,f2,fmed - real(kind=8) :: tolx=1.0d-4, tolf=1.0d-4 - real(kind=8) :: sumcos -!el real(kind=8) :: pinorm,sumangp !arcos, - integer :: it,maxit=100 -! Calculate the difference of the angles of two superposed 4-redidue fragments -! -! O P -! \ / -! O'--C--C -! \ -! P' -! -! The fragment O'-C-C-P' is rotated by angle fi about the C-C axis -! to achieve the minimum difference between the O'-C-O and P-C-P angles; -! the sum of these angles is the difference returned by the function. -! -! 4/28/04 AL -! If thetas match, take the difference of gamma and exit. - if (dabs(theta11-theta12).lt.tolx & - .and. dabs(theta21-theta22).lt.tolx) then - spherang=dabs(pinorm(gam2-gam1)) - return - endif -! If the gammas are the same, take the difference of thetas and exit. - x1=0.0d0 - x2=0.5d0*pinorm(gam2-gam1) - if (dabs(x2) .lt. tolx) then - spherang=dabs(theta11-theta21)+dabs(theta12-theta22) - return - else if (x2.lt.0.0d0) then - x1=x2 - x2=0.0d0 - endif -! Else apply regula falsi method to compute optimum overlap of the terminal Calphas - f1=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x1) - f2=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x2) - do it=1,maxit - xmed=x1-f1*(x2-x1)/(f2-f1) - fmed=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,xmed) -! write (*,*) 'it',it,' xmed ',xmed,' fmed ',fmed - if ( (dabs(xmed-x1).lt.tolx .or. dabs(x2-xmed).lt.tolx) & - .and. dabs(fmed).lt.tolf ) then - x1=xmed - f1=fmed - goto 10 - else if ( fmed*f1.lt.0.0d0 ) then - x2=xmed - f2=fmed - else - x1=xmed - f1=fmed - endif - enddo - 10 continue - spherang=arcos(dcos(theta11)*dcos(theta12) & - +dsin(theta11)*dsin(theta12)*dcos(x1))+ & - arcos(dcos(theta21)*dcos(theta22)+ & - dsin(theta21)*dsin(theta22)*dcos(gam2-gam1+x1)) - return - end function spherang -!-------------------------------------------------------------------------------- - real(kind=8) function sumangp(gam1,theta11,theta12,gam2,& - theta21,theta22,fi) -! implicit none - real(kind=8) :: gam1,theta11,theta12,gam2,theta21,theta22,fi,& - cost11,cost12,cost21,cost22,sint11,sint12,sint21,sint22,cosd1,& - cosd2 -! derivarive of the sum of the difference of the angles of a 4-residue fragment. -! real(kind=8) :: arcos - cost11=dcos(theta11) - cost12=dcos(theta12) - cost21=dcos(theta21) - cost22=dcos(theta22) - sint11=dsin(theta11) - sint12=dsin(theta12) - sint21=dsin(theta21) - sint22=dsin(theta22) - cosd1=cost11*cost12+sint11*sint12*dcos(fi) - cosd2=cost21*cost22+sint21*sint22*dcos(gam2-gam1+fi) - sumangp=sint11*sint12*dsin(fi)/dsqrt(1.0d0-cosd1*cosd1) & - +sint21*sint22*dsin(gam2-gam1+fi)/dsqrt(1.0d0-cosd2*cosd2) - return - end function sumangp -!----------------------------------------------------------------------------- -! contact.f -!----------------------------------------------------------------------------- - subroutine contact(lprint,ncont,icont,ist,ien) - - use calc_data - use geometry_data, only:c,dc,dc_norm - use energy_data, only:itype,maxcont -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'COMMON.CONTROL' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' -! include 'COMMON.CALC' -! include 'COMMON.CONTPAR' -! include 'COMMON.LOCAL' - integer :: ist,ien,kkk,iti,itj,itypi,itypj,i1,i2,it1,it2 - real(kind=8) :: csc !el,dist - real(kind=8),dimension(maxcont) :: cscore,omt1,omt2,omt12,& - ddsc,ddla,ddlb - integer :: ncont - integer,dimension(2,maxcont) :: icont - real(kind=8) :: u,v,a(3),b(3),dla,dlb - logical :: lprint -!el------- - dla=0.0d0 - dlb=0.0d0 -!el------ - ncont=0 - kkk=3 - if (lprint) then - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),& - c(3,i),dc(1,nres+i),dc(2,nres+i),dc(3,nres+i),& - dc_norm(1,nres+i),dc_norm(2,nres+i),dc_norm(3,nres+i) - enddo - endif - 110 format (a,'(',i3,')',9f8.3) - do i=ist,ien-kkk - iti=iabs(itype(i)) - if (iti.le.0 .or. iti.gt.ntyp) cycle - do j=i+kkk,ien - itj=iabs(itype(j)) - if (itj.le.0 .or. itj.gt.ntyp) cycle - itypi=iti - itypj=itj - xj = c(1,nres+j)-c(1,nres+i) - yj = c(2,nres+j)-c(2,nres+i) - zj = c(3,nres+j)-c(3,nres+i) - dxi = dc_norm(1,nres+i) - dyi = dc_norm(2,nres+i) - dzi = dc_norm(3,nres+i) - dxj = dc_norm(1,nres+j) - dyj = dc_norm(2,nres+j) - dzj = dc_norm(3,nres+j) - do k=1,3 - a(k)=dc(k,nres+i) - b(k)=dc(k,nres+j) - enddo -! write (iout,*) (a(k),k=1,3),(b(k),k=1,3) - if (icomparfunc.eq.1) then - call contfunc(csc,iti,itj) - else if (icomparfunc.eq.2) then - call scdist(csc,iti,itj) - else if (icomparfunc.eq.3 .or. icomparfunc.eq.5) then - csc = dist(nres+i,nres+j) - else if (icomparfunc.eq.4) then - call odlodc(c(1,i),c(1,j),a,b,u,v,dla,dlb,csc) - else - write (*,*) "Error - Unknown sidechain contact function" - write (iout,*) "Error - Unknown sidechain contact function" - endif - if (csc.lt.sc_cutoff(iti,itj)) then -! write(iout,*) "i",i," j",j," dla",dla,dsc(iti), -! & " dlb",dlb,dsc(itj)," csc",csc,sc_cutoff(iti,itj), -! & dxi,dyi,dzi,dxi**2+dyi**2+dzi**2, -! & dxj,dyj,dzj,dxj**2+dyj**2+dzj**2,om1,om2,om12, -! & xj,yj,zj -! write(iout,*)'egb',itypi,itypj,chi1,chi2,chip1,chip2, -! & sig0ij,rij,rrij,om1,om2,om12,chiom1,chiom2,chiom12, -! & chipom1,chipom2,chipom12,sig,eps2rt,rij_shift,e2,evdw, -! & csc - ncont=ncont+1 - cscore(ncont)=csc - icont(1,ncont)=i - icont(2,ncont)=j - omt1(ncont)=om1 - omt2(ncont)=om2 - omt12(ncont)=om12 - ddsc(ncont)=1.0d0/rij - ddla(ncont)=dla - ddlb(ncont)=dlb - 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,5f8.3,3f10.5)') & - i,restyp(it1),i1,restyp(it2),i2,cscore(i),& - sc_cutoff(iabs(it1),iabs(it2)),ddsc(i),ddla(i),ddlb(i),& - omt1(i),omt2(i),omt12(i) - enddo - endif - return - end subroutine contact -#else -!---------------------------------------------------------------------------- - subroutine contact(lprint,ncont,icont) - - use energy_data, only: nnt,nct,itype,ipot,maxcont,sigma,sigmaii -! 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,icont(2,maxcont) - logical :: lprint - integer :: kkk,i,j,i1,i2,it1,it2,iti,itj - real(kind=8) :: rcomp - ncont=0 - kkk=3 -! print *,'nnt=',nnt,' nct=',nct - do i=nnt+kkk,nct - iti=iabs(itype(i)) - do j=nnt,i-kkk - itj=iabs(itype(j)) - if (ipot.ne.4) then -! 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 - return - end subroutine contact -#endif -!---------------------------------------------------------------------------- - real(kind=8) function contact_fract(ncont,ncont_ref,& - icont,icont_ref) - - use energy_data, only:maxcont -! implicit none -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer :: i,j,nmatch - integer :: ncont,ncont_ref - integer,dimension(2,maxcont) :: icont,icont_ref - 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 -#ifndef CLUSTER -!------------------------------------------------------------------------------ - subroutine pept_cont(lprint,ncont,icont) - - use geometry_data, only:c - use energy_data, only:maxcont,nnt,nct,itype -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' - integer :: ncont,icont(2,maxcont) - integer :: i,j,k,kkk,i1,i2,it1,it2 - logical :: lprint -!el real(kind=8) :: dist - real(kind=8) :: rcomp=5.5d0 - ncont=0 - kkk=0 - print *,'Entering pept_cont: 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 - return - end subroutine pept_cont -!----------------------------------------------------------------------------- -! cont_frag.f -!----------------------------------------------------------------------------- - subroutine contacts_between_fragments(lprint,is,ncont,icont,& - ncont_interfrag,icont_interfrag) - - use energy_data, only:itype,maxcont -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.INTERACT' -! include 'COMMON.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.NAMES' - integer :: icont(2,maxcont),ncont_interfrag(mmaxfrag),& - icont_interfrag(2,maxcont,mmaxfrag) - logical :: OK1,OK2,lprint - integer :: is,ncont,i,j,ind,nc,k,ic1,ic2,l,i1,i2,it1,it2 -! Determine the contacts that occur within a fragment and between fragments. - do i=1,nfrag(1) - do j=1,i - ind = icant(i,j) - nc=0 -! write (iout,*) "i",i,(ifrag(1,k,i),ifrag(2,k,i) -! & ,k=1,npiece(i,1)) -! write (iout,*) "j",j,(ifrag(1,k,j),ifrag(2,k,j) -! & ,k=1,npiece(j,1)) -! write (iout,*) "ncont",ncont - do k=1,ncont - ic1=icont(1,k) - ic2=icont(2,k) - OK1=.false. - l=0 - do while (.not.OK1 .and. l.lt.npiece(j,1)) - l=l+1 - OK1=ic1.ge.ifrag(1,l,j)-is .and. & - ic1.le.ifrag(2,l,j)+is - enddo - OK2=.false. - l=0 - do while (.not.OK2 .and. l.lt.npiece(i,1)) - l=l+1 - OK2=ic2.ge.ifrag(1,l,i)-is .and. & - ic2.le.ifrag(2,l,i)+is - enddo -! write(iout,*) "k",k," ic1",ic1," ic2",ic2," OK1",OK1, -! & " OK2",OK2 - if (OK1.and.OK2) then - nc=nc+1 - icont_interfrag(1,nc,ind)=ic1 - icont_interfrag(2,nc,ind)=ic2 -! write (iout,*) "nc",nc," ic1",ic1," ic2",ic2 - endif - enddo - ncont_interfrag(ind)=nc -! do k=1,ncont_interfrag(ind) -! i1=icont_interfrag(1,k,ind) -! i2=icont_interfrag(2,k,ind) -! it1=itype(i1) -! it2=itype(i2) -! write (iout,'(i3,2x,a,i4,2x,a,i4)') -! & i,restyp(it1),i1,restyp(it2),i2 -! enddo - enddo - enddo - if (lprint) then - write (iout,*) "Contacts within fragments:" - do i=1,nfrag(1) - write (iout,*) "Fragment",i," (",(ifrag(1,k,i),& - ifrag(2,k,i),k=1,npiece(i,1)),")" - ind=icant(i,i) - do k=1,ncont_interfrag(ind) - i1=icont_interfrag(1,k,ind) - i2=icont_interfrag(2,k,ind) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') & - i,restyp(it1),i1,restyp(it2),i2 - enddo - enddo - write (iout,*) - write (iout,*) "Contacts between fragments:" - do i=1,nfrag(1) - do j=1,i-1 - ind = icant(i,j) - write (iout,*) "Fragments",i," (",(ifrag(1,k,i),& - ifrag(2,k,i),k=1,npiece(i,1)),") and",j," (",& - (ifrag(1,k,j),ifrag(2,k,j),k=1,npiece(j,1)),")" - write (iout,*) "Number of contacts",& - ncont_interfrag(ind) - ind=icant(i,j) - do k=1,ncont_interfrag(ind) - i1=icont_interfrag(1,k,ind) - i2=icont_interfrag(2,k,ind) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') & - i,restyp(it1),i1,restyp(it2),i2 - enddo - enddo - enddo - endif - return - end subroutine contacts_between_fragments -!----------------------------------------------------------------------------- -! contfunc.f -!----------------------------------------------------------------------------- - subroutine contfunc(cscore,itypi,itypj) -! -! This subroutine calculates the contact function based on -! the Gay-Berne potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTPAR' -! include 'COMMON.CALC' - integer :: expon=6 - integer :: itypi,itypj - real(kind=8) :: cscore,sig0ij,rrij,sig,rij_shift,evdw,e2 -! - sig0ij=sig_comp(itypi,itypj) - chi1=chi_comp(itypi,itypj) - chi2=chi_comp(itypj,itypi) - chi12=chi1*chi2 - chip1=chip_comp(itypi,itypj) - chip2=chip_comp(itypj,itypi) - chip12=chip1*chip2 - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) -! Calculate angle-dependent terms of the contact function - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - chiom12=chi12*om12 -! print *,'egb',itypi,itypj,chi1,chi2,chip1,chip2, -! & sig0ij, -! & rij,rrij,om1,om2,om12 -! Calculate eps1(om12) - faceps1=1.0D0-om12*chiom12 - faceps1_inv=1.0D0/faceps1 - eps1=dsqrt(faceps1_inv) -! Following variable is eps1*deps1/dom12 - eps1_om12=faceps1_inv*chiom12 -! Calculate sigma(om1,om2,om12) - om1om2=om1*om2 - chiom1=chi1*om1 - chiom2=chi2*om2 - facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 - sigsq=1.0D0-facsig*faceps1_inv -! Calculate eps2 and its derivatives in om1, om2, and om12. - chipom1=chip1*om1 - chipom2=chip2*om2 - chipom12=chip12*om12 - facp=1.0D0-om12*chipom12 - facp_inv=1.0D0/facp - facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 -! Following variable is the square root of eps2 - eps2rt=1.0D0-facp1*facp_inv - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij - if (rij_shift.le.0.0D0) then - evdw=1.0D1 - cscore = -dlog(evdw+1.0d-6) - return - endif - rij_shift=1.0D0/rij_shift - e2=(rij_shift*sig0ij)**expon - evdw=dabs(eps1*eps2rt**2*e2) - if (evdw.gt.1.0d1) evdw = 1.0d1 - cscore = -dlog(evdw+1.0d-6) - return - end subroutine contfunc -!------------------------------------------------------------------------------ - subroutine scdist(cscore,itypi,itypj) -! -! This subroutine calculates the contact distance -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CONTPAR' -! include 'COMMON.CALC' - integer :: itypi,itypj - real(kind=8) :: cscore,rrij - - chi1=chi_comp(itypi,itypj) - chi2=chi_comp(itypj,itypi) - chi12=chi1*chi2 - rrij=xj*xj+yj*yj+zj*zj - rij=dsqrt(rrij) -! Calculate angle-dependent terms of the contact function - erij(1)=xj/rij - erij(2)=yj/rij - erij(3)=zj/rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - chiom12=chi12*om12 - om1om2=om1*om2 - chiom1=chi1*om1 - chiom2=chi2*om2 - cscore=dsqrt(rrij+chi1**2+chi2**2+2*rij*(chiom2-chiom1)-2*chiom12) - return - end subroutine scdist -!------------------------------------------------------------------------------ -! elecont.f -!------------------------------------------------------------------------------ - subroutine elecont(lprint,ncont,icont,ist,ien) - - use geometry_data, only:c - use energy_data, only:maxcont,rpp,epp,itype,itel,vblinv,vblinv2 -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' -! include 'COMMON.LOCAL' - logical :: lprint - integer :: i,j,k,ist,ien,iteli,itelj,ind,i1,i2,it1,it2,ic1,ic2 - real(kind=8) :: rri,xi,yi,zi,dxi,dyi,dzi,xmedi,ymedi,zmedi,& - xj,yj,zj,dxj,dyj,dzj,aaa,bbb,ael6i,ael3i,rrmij,rmij,r3ij,r6ij,& - vrmij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,evdwij,el1,el2,& - eesij,ees,evdw,ene - real(kind=8),dimension(2,2) :: elpp6c=reshape((/-0.2379d0,& - -0.2056d0,-0.2056d0,-0.0610d0/),shape(elpp6c)) - real(kind=8),dimension(2,2) :: elpp3c=reshape((/ 0.0503d0,& - 0.0000d0, 0.0000d0, 0.0692d0/),shape(elpp3c)) - real(kind=8),dimension(2,2) :: ael6c,ael3c,appc,bppc - real(kind=8) :: elcutoff=-0.3d0 - real(kind=8) :: elecutoff_14=-0.5d0 - integer :: ncont,icont(2,maxcont) - real(kind=8) :: econt(maxcont) -! -! Load the constants of peptide bond - peptide bond interactions. -! Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. -! proline) - determined by averaging ECEPP energy. -! -! as of 7/06/91. -! -! data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ -! data rpp / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/ -!el data (elpp6c) /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/ -!el data (elpp3c) / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/ -!el data (elcutoff) /-0.3d0/ -!el data (elecutoff_14) /-0.5d0/ - ees=0.0d0 - evdw=0.0d0 - if (lprint) write (iout,'(a)') & - "Constants of electrostatic interaction energy expression." - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - appc(i,j)=epp(i,j)*rri*rri - bppc(i,j)=-2.0*epp(i,j)*rri - ael6c(i,j)=elpp6c(i,j)*4.2**6 - ael3c(i,j)=elpp3c(i,j)*4.2**3 - if (lprint) & - write (iout,'(2i2,4e15.4)') i,j,appc(i,j),bppc(i,j),ael6c(i,j),& - ael3c(i,j) - enddo - enddo - ncont=0 - do 1 i=ist,ien-2 - xi=c(1,i) - yi=c(2,i) - zi=c(3,i) - dxi=c(1,i+1)-c(1,i) - dyi=c(2,i+1)-c(2,i) - dzi=c(3,i+1)-c(3,i) - xmedi=xi+0.5*dxi - ymedi=yi+0.5*dyi - zmedi=zi+0.5*dzi - do 4 j=i+2,ien-1 - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - if (iteli.eq.2 .and. itelj.eq.2 & - .or.iteli.eq.0 .or.itelj.eq.0) goto 4 - aaa=appc(iteli,itelj) - bbb=bppc(iteli,itelj) - ael6i=ael6c(iteli,itelj) - ael3i=ael3c(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=ael6i*r6ij - fac4=ael3i*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 -!------------------------------------------------------------------------------ -! match_contact.f -!------------------------------------------------------------------------------ - subroutine match_contact(ishif1,ishif2,nc_match,nc_match1_max,& - ncont_ref,icont_ref,ncont,icont,jfrag,n_shif1,n_shif2,& - nc_frac,nc_req_set,istr,llocal,lprn) - - use energy_data, only:maxcont -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' - integer :: ncont_ref,ncont,ishift,ishif2,nc_match - integer,dimension(2,maxcont) :: icont_ref,icont !(2,maxcont) - real(kind=8) :: nc_frac - logical :: llocal,lprn - integer :: ishif1,nc_match1_max,jfrag,n_shif1,n_shif2,& - nc_req_set,istr,nc_match_max - integer :: i,nc_req,nc_match1,is,js - nc_match_max=0 - do i=1,ncont_ref - nc_match_max=nc_match_max+ & - min0(icont_ref(2,i)-icont_ref(1,i)-1,3) - enddo - if (istr.eq.3) then - nc_req=0 - else if (nc_req_set.eq.0) then - nc_req=nc_match_max*nc_frac - else - nc_req = dmin1(nc_match_max*nc_frac+0.5d0,& - dfloat(nc_req_set)+1.0d-7) - endif -! write (iout,*) "match_contact: nc_req:",nc_req -! write (iout,*) "nc_match_max",nc_match_max -! write (iout,*) "jfrag",jfrag," n_shif1",n_shif1, -! & " n_shif2",n_shif2 -! Match current contact map against reference contact map; exit, if at least -! half of the contacts match - call ncont_match(nc_match,nc_match1,0,0,ncont_ref,icont_ref,& - ncont,icont,jfrag,llocal,lprn) - nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",0,0," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. & - nc_req.eq.0 .and. nc_match.eq.1) then - ishif1=0 - ishif2=0 - return - endif -! If sufficient matches are not found, try to shift contact maps up to three -! positions. - if (n_shif1.gt.0) then - do is=1,n_shif1 -! The following four tries help to find shifted beta-sheet patterns -! Shift "left" strand backward - call ncont_match(nc_match,nc_match1,-is,0,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",-is,0," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. & - nc_req.eq.0 .and. nc_match.eq.1) then - ishif1=-is - ishif2=0 - return - endif -! Shift "left" strand forward - call ncont_match(nc_match,nc_match1,is,0,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",is,0," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. & - nc_req.eq.0 .and. nc_match.eq.1) then - ishif1=is - ishif2=0 - return - endif - enddo - if (nc_req.eq.0) return -! Shift "right" strand backward - do is=1,n_shif1 - call ncont_match(nc_match,nc_match1,0,-is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",0,-is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=0 - ishif2=-is - return - endif -! Shift "right" strand upward - call ncont_match(nc_match,nc_match1,0,is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",0,is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=0 - ishif2=is - return - endif - enddo ! is -! Now try to shift both residues in contacts. - do is=1,n_shif1 - do js=1,is - if (js.ne.is) then - call ncont_match(nc_match,nc_match1,-is,-js,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",-is,-js," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=-js - return - endif - call ncont_match(nc_match,nc_match1,is,js,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",is,js," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=is - ishif2=js - return - endif -! - call ncont_match(nc_match,nc_match1,-js,-is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",-js,-is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-js - ishif2=-is - return - endif -! - call ncont_match(nc_match,nc_match1,js,is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",js,is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=js - ishif2=is - return - endif - endif -! - if (is+js.le.n_shif1) then - call ncont_match(nc_match,nc_match1,-is,js,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",-is,js," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=js - return - endif -! - call ncont_match(nc_match,nc_match1,js,-is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",js,-is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=js - ishif2=-is - return - endif - endif -! - enddo !js - enddo !is - endif - - if (n_shif2.gt.0) then - do is=1,n_shif2 - call ncont_match(nc_match,nc_match1,-is,-is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",-is,-is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=-is - return - endif - call ncont_match(nc_match,nc_match1,is,is,ncont_ref,& - icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) & - "Shift:",is,is," nc_match1",nc_match1,& - " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=is - ishif2=is - return - endif - enddo - endif -! If this point is reached, the contact maps are different. - nc_match=0 - ishif1=0 - ishif2=0 - return - end subroutine match_contact -!------------------------------------------------------------------------- - subroutine ncont_match(nc_match,nc_match1,ishif1,ishif2,& - ncont_ref,icont_ref,ncont,icont,jfrag,llocal,lprn) - - use energy_data, only:nnt,nct,maxcont -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.INTERACT' -! include 'COMMON.GEO' -! include 'COMMON.COMPAR' - logical :: llocal,lprn - integer ncont_ref,ncont,ishift,ishif2,nang_pair - integer,dimension(2,maxcont) :: icont_ref,icont,icont_match !(2,maxcont) - integer,dimension(2,nres) :: iang_pair !(2,maxres) - integer :: nc_match,nc_match1,ishif1,jfrag - integer :: i,j,ic1,ic2 - real(kind=8) :: diffang,fract,rad2deg - -! Compare the contact map against the reference contact map; they're stored -! in ICONT and ICONT_REF, respectively. The current contact map can be shifted. - if (lprn) write (iout,'(80(1h*))') - nc_match=0 - nc_match1=0 -! Check the local structure by comparing dihedral angles. -! write (iout,*) "ncont_match: ncont_ref",ncont_ref," llocal",llocal - if (llocal .and. ncont_ref.eq.0) then -! If there are no contacts just compare the dihedral angles and exit. - call angnorm(jfrag,ishif1,ishif2,ang_cut1(jfrag),diffang,fract,& - lprn) - if (lprn) write (iout,*) "diffang:",diffang*rad2deg,& - " ang_cut:",ang_cut(jfrag)*rad2deg," fract",fract - if (diffang.le.ang_cut(jfrag) .and. fract.ge.frac_min(jfrag)) & - then - nc_match=1 - else - nc_match=0 - endif - return - endif - nang_pair=0 - do i=1,ncont - ic1=icont(1,i)+ishif1 - ic2=icont(2,i)+ishif2 -! write (iout,*) "i",i," ic1",ic1," ic2",ic2 - if (ic1.lt.nnt .or. ic2.gt.nct) goto 10 - do j=1,ncont_ref - if (ic1.eq.icont_ref(1,j).and.ic2.eq.icont_ref(2,j)) then - nc_match=nc_match+min0(icont_ref(2,j)-icont_ref(1,j)-1,3) - nc_match1=nc_match1+1 - icont_match(1,nc_match1)=ic1 - icont_match(2,nc_match1)=ic2 -! call add_angpair(icont(1,i),icont_ref(1,j), -! & nang_pair,iang_pair) -! call add_angpair(icont(2,i),icont_ref(2,j), -! & nang_pair,iang_pair) - if (lprn) write (iout,*) "Contacts:",icont(1,i),icont(2,i),& - " match",icont_ref(1,j),icont_ref(2,j),& - " shifts",ishif1,ishif2 - goto 10 - endif - enddo - 10 continue - enddo - if (lprn) then - write (iout,*) "nc_match",nc_match," nc_match1",nc_match1 - write (iout,*) "icont_match" - do i=1,nc_match1 - write (iout,*) icont_match(1,i),icont_match(2,i) - enddo - endif - if (llocal .and. nc_match.gt.0) then - call angnorm2(jfrag,ishif1,ishif2,nc_match1,icont_match,lprn,& - ang_cut1(jfrag),diffang,fract) - if (lprn) write (iout,*) "diffang:",diffang*rad2deg,& - " ang_cut:",ang_cut(jfrag)*rad2deg,& - " ang_cut1",ang_cut1(jfrag)*rad2deg - if (diffang.gt.ang_cut(jfrag) & - .or. fract.lt.frac_min(jfrag)) nc_match=0 - endif -! if (nc_match.gt.0) then -! diffang = angnorm1(nang_pair,iang_pair,lprn) -! if (diffang.gt.ang_cut(jfrag)) nc_match=0 -! endif - if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2,& - " diffang",rad2deg*diffang," nc_match",nc_match - return - end subroutine ncont_match -!------------------------------------------------------------------------------ - subroutine match_secondary(jfrag,isecstr,nsec_match,lprn) -! This subroutine compares the secondary structure (isecstr) of fragment jfrag -! conformation considered to that of the reference conformation. -! Returns the number of equivalent residues (nsec_match). -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.PEPTCONT' -! include 'COMMON.COMPAR' - logical :: lprn - integer :: isecstr(nres) - integer :: jfrag,nsec_match,npart,i,j - npart = npiece(jfrag,1) - nsec_match=0 - if (lprn) then - write (iout,*) "match_secondary jfrag",jfrag," ifrag",& - (ifrag(1,i,jfrag),ifrag(2,i,jfrag),i=1,npart) - write (iout,'(80i1)') (isec_ref(j),j=1,nres) - write (iout,'(80i1)') (isecstr(j),j=1,nres) - endif - do i=1,npart - do j=ifrag(1,i,jfrag),ifrag(2,i,jfrag) -! The residue has equivalent conformational state to that of the reference -! structure, if: -! a) the conformational states are equal or -! b) the reference state is a coil and that of the conformation considered -! is a strand or -! c) the conformational state of the conformation considered is a strand -! and that of the reference conformation is a coil. -! 10/28/02 - case (b) deleted. - if (isecstr(j).eq.isec_ref(j) .or. & -! & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or. - isec_ref(j).eq.0 .and. isecstr(j).eq.1) & - nsec_match=nsec_match+1 - enddo - enddo - return - end subroutine match_secondary -!------------------------------------------------------------------------------ -! odlodc.f -!------------------------------------------------------------------------------ - subroutine odlodc(r1,r2,a,b,uu,vv,aa,bb,dd) - - use energy_data, only:ncont_ref,icont_ref!,nsccont_frag_ref,& -! isccont_frag_ref -! implicit real*8 (a-h,o-z) - real(kind=8),dimension(3) :: r1,r2,a,b,x,y - real(kind=8) :: uu,vv,aa,bb,dd - real(kind=8) :: ab,ar,br,det,dd1,dd2,dd3,dd4,dd5 -!el odl(u,v) = (r1(1)-r2(1))**2+(r1(2)-r2(2))**2+(r1(3)-r2(3))**2 & -!el + 2*ar*u - 2*br*v - 2*ab*u*v + aa*u**2 + bb*v**2 -! print *,"r1",(r1(i),i=1,3) -! print *,"r2",(r2(i),i=1,3) -! print *,"a",(a(i),i=1,3) -! print *,"b",(b(i),i=1,3) - aa = a(1)**2+a(2)**2+a(3)**2 - bb = b(1)**2+b(2)**2+b(3)**2 - ab = a(1)*b(1)+a(2)*b(2)+a(3)*b(3) - ar = a(1)*(r1(1)-r2(1))+a(2)*(r1(2)-r2(2))+a(3)*(r1(3)-r2(3)) - br = b(1)*(r1(1)-r2(1))+b(2)*(r1(2)-r2(2))+b(3)*(r1(3)-r2(3)) - det = aa*bb-ab**2 -! print *,'aa',aa,' bb',bb,' ab',ab,' ar',ar,' br',br,' det',det - uu = (-ar*bb+br*ab)/det - vv = (br*aa-ar*ab)/det -! print *,u,v - uu=dmin1(uu,1.0d0) - uu=dmax1(uu,0.0d0) - vv=dmin1(vv,1.0d0) - vv=dmax1(vv,0.0d0) -!el dd1 = odl(uu,vv) - dd1 = odl(uu,vv,r1,r2,ar,br,ab,aa,bb) -!el dd2 = odl(0.0d0,0.0d0) - dd2 = odl(0.0d0,0.0d0,r1,r2,ar,br,ab,aa,bb) -!el dd3 = odl(0.0d0,1.0d0) - dd3 = odl(0.0d0,1.0d0,r1,r2,ar,br,ab,aa,bb) -!el dd4 = odl(1.0d0,0.0d0) - dd4 = odl(1.0d0,0.0d0,r1,r2,ar,br,ab,aa,bb) -!el dd5 = odl(1.0d0,1.0d0) - dd5 = odl(1.0d0,1.0d0,r1,r2,ar,br,ab,aa,bb) - dd = dsqrt(dmin1(dd1,dd2,dd3,dd4,dd5)) - if (dd.eq.dd2) then - uu=0.0d0 - vv=0.0d0 - else if (dd.eq.dd3) then - uu=0.0d0 - vv=1.0d0 - else if (dd.eq.dd4) then - uu=1.0d0 - vv=0.0d0 - else if (dd.eq.dd5) then - uu=1.0d0 - vv=1.0d0 - endif -! Control check -! do i=1,3 -! x(i)=r1(i)+u*a(i) -! y(i)=r2(i)+v*b(i) -! enddo -! dd1 = (x(1)-y(1))**2+(x(2)-y(2))**2+(x(3)-y(3))**2 -! dd1 = dsqrt(dd1) - aa = dsqrt(aa) - bb = dsqrt(bb) -! write (8,*) uu,vv,dd,dd1 -! print *,dd,dd1 - return - end subroutine odlodc -!------------------------------------------------------------------------------ - real(kind=8) function odl(u,v,r1,r2,ar,br,ab,aa,bb) - - real(kind=8),dimension(3) :: r1,r2 - real(kind=8) :: aa,bb,u,v,ar,br,ab - - odl = (r1(1)-r2(1))**2+(r1(2)-r2(2))**2+(r1(3)-r2(3))**2 & - + 2*ar*u - 2*br*v - 2*ab*u*v + aa*u**2 + bb*v**2 - - end function odl -!------------------------------------------------------------------------------ -! proc_cont.f -!------------------------------------------------------------------------------ - subroutine proc_cont - - use geometry_data, only:rad2deg - use energy_data, only:ncont_ref,icont_ref!,nsccont_frag_ref,& -! isccont_frag_ref -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.HEADER' -! include 'COMMON.CONTACTS1' -! include 'COMMON.PEPTCONT' -! include 'COMMON.GEO' - integer :: i,j,k,ind,len_cut,ndigit,length_frag - - write (iout,*) "proc_cont: nlevel",nlevel - if (nlevel.lt.0) then - write (iout,*) "call define_fragments" - call define_fragments - else - write (iout,*) "call secondary2" - call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref,& - isec_ref) - endif - write (iout,'(80(1h=))') - write (iout,*) "Electrostatic contacts" - call contacts_between_fragments(.true.,0,ncont_pept_ref,& - icont_pept_ref,ncont_frag_ref(1),icont_frag_ref(1,1,1)) - write (iout,'(80(1h=))') - write (iout,*) "Side chain contacts" - call contacts_between_fragments(.true.,0,ncont_ref,& - icont_ref,nsccont_frag_ref(1),isccont_frag_ref(1,1,1)) - if (nlevel.lt.0) then - do i=1,nfrag(1) - ind=icant(i,i) - len_cut=1000 - if (istruct(i).le.1) then - len_cut=max0(len_frag(i,1)*4/5,3) - else if (istruct(i).eq.2 .or. istruct(i).eq.4) then - len_cut=max0(len_frag(i,1)*2/5,3) - endif - write (iout,*) "i",i," istruct",istruct(i)," ncont_frag",& - ncont_frag_ref(ind)," len_cut",len_cut,& - " icont_single",icont_single," iloc_single",iloc_single - iloc(i)=iloc_single - if (iloc(i).gt.0) write (iout,*) & - "Local structure used to compare structure of fragment",i,& - " to native." - if (istruct(i).ne.3 .and. istruct(i).ne.0 & - .and. icont_single.gt.0 .and. & - ncont_frag_ref(ind).ge.len_cut) then - write (iout,*) "Electrostatic contacts used to compare",& - " structure of fragment",i," to native." - ielecont(i,1)=1 - isccont(i,1)=0 - else if (icont_single.gt.0 .and. nsccont_frag_ref(ind) & - .ge.len_cut) then - write (iout,*) "Side chain contacts used to compare",& - " structure of fragment",i," to native." - isccont(i,1)=1 - ielecont(i,1)=0 - else - write (iout,*) "Contacts not used to compare",& - " structure of fragment",i," to native." - ielecont(i,1)=0 - isccont(i,1)=0 - nc_req_setf(i,1)=0 - endif - if (irms_single.gt.0 .or. isccont(i,1).eq.0 & - .and. ielecont(i,1).eq.0) then - write (iout,*) "RMSD used to compare",& - " structure of fragment",i," to native." - irms(i,1)=1 - else - write (iout,*) "RMSD not used to compare",& - " structure of fragment",i," to native." - irms(i,1)=0 - endif - enddo - endif - if (nlevel.lt.-1) then - call define_pairs - nlevel = -nlevel - if (nlevel.gt.3) nlevel=3 - if (nlevel.eq.3) then - nfrag(3)=1 - npiece(1,3)=nfrag(1) - do i=1,nfrag(1) - ipiece(i,1,3)=i - enddo - ielecont(1,3)=0 - isccont(1,3)=0 - irms(1,3)=1 - n_shift(1,1,3)=0 - n_shift(2,1,3)=0 - endif - else if (nlevel.eq.-1) then - nlevel=1 - endif - isnfrag(1)=0 - do i=1,nlevel - isnfrag(i+1)=isnfrag(i)+nfrag(i) - enddo - ndigit=3*nfrag(1) - do i=2,nlevel - ndigit=ndigit+2*nfrag(i) - enddo - write (iout,*) "ndigit",ndigit - if (.not.binary .and. ndigit.gt.30) then - write (iout,*) "Highest class too large; switching to",& - " binary representation." - binary=.true. - endif - write (iout,*) "isnfrag",(isnfrag(i),i=1,nlevel+1) - write(iout,*) "rmscut_base_up",rmscut_base_up,& - " rmscut_base_low",rmscut_base_low," rmsup_lim",rmsup_lim - do i=1,nlevel - do j=1,nfrag(i) - length_frag = 0 - if (i.eq.1) then - do k=1,npiece(j,i) - length_frag=length_frag+ifrag(2,k,j)-ifrag(1,k,j)+1 - enddo - else - do k=1,npiece(j,i) - length_frag=length_frag+len_frag(ipiece(k,j,i),1) - enddo - endif - len_frag(j,i)=length_frag - rmscutfrag(1,j,i)=rmscut_base_up*length_frag - rmscutfrag(2,j,i)=rmscut_base_low*length_frag - if (rmscutfrag(1,j,i).lt.rmsup_lim) & - rmscutfrag(1,j,i)=rmsup_lim - if (rmscutfrag(1,j,i).gt.rmsupup_lim) & - rmscutfrag(1,j,i)=rmsupup_lim - enddo - enddo - write (iout,*) "Level",1," number of fragments:",nfrag(1) - do j=1,nfrag(1) - write (iout,*) npiece(j,1),(ifrag(1,k,j),ifrag(2,k,j),& - k=1,npiece(j,1)),len_frag(j,1),rmscutfrag(1,j,1),& - rmscutfrag(2,j,1),n_shift(1,j,1),n_shift(2,j,1),& - ang_cut(j)*rad2deg,ang_cut1(j)*rad2deg,frac_min(j),& - nc_fragm(j,1),nc_req_setf(j,1),istruct(j) - enddo - do i=2,nlevel - write (iout,*) "Level",i," number of fragments:",nfrag(i) - do j=1,nfrag(i) - write (iout,*) npiece(j,i),(ipiece(k,j,i),& - k=1,npiece(j,i)),len_frag(j,i),rmscutfrag(1,j,i),& - rmscutfrag(2,j,i),n_shift(1,j,i),n_shift(2,j,i),& - nc_fragm(j,i),nc_req_setf(j,i) - enddo - enddo - return - end subroutine proc_cont -!------------------------------------------------------------------------------ -! define_pairs.f -!------------------------------------------------------------------------------ - subroutine define_pairs - -! use energy_data, only:nsccont_frag_ref -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.COMPAR' -! include 'COMMON.FRAG' -! include 'COMMON.CHAIN' -! include 'COMMON.HEADER' -! include 'COMMON.GEO' -! include 'COMMON.CONTACTS1' -! include 'COMMON.PEPTCONT' - integer :: j,k,i,length_frag,ind,ll1,ll2,len_cut - - do j=1,nfrag(1) - length_frag = 0 - do k=1,npiece(j,1) - length_frag=length_frag+ifrag(2,k,j)-ifrag(1,k,j)+1 - enddo - len_frag(j,1)=length_frag - write (iout,*) "Fragment",j," length",len_frag(j,1) - enddo - nfrag(2)=0 - do i=1,nfrag(1) - do j=i+1,nfrag(1) - ind = icant(i,j) - if (istruct(i).le.1 .or. istruct(j).le.1) then - if (istruct(i).le.1) then - ll1=len_frag(i,1) - else - ll1=len_frag(i,1)/2 - endif - if (istruct(j).le.1) then - ll2=len_frag(j,1) - else - ll2=len_frag(j,1)/2 - endif - len_cut=max0(min0(ll1*2/3,ll2*4/5),3) - else - if (istruct(i).eq.2 .or. istruct(i).eq.4) then - ll1=len_frag(i,1)/2 - else - ll1=len_frag(i,1) - endif - if (istruct(j).eq.2 .or. istruct(j).eq.4) then - ll2=len_frag(j,1)/2 - else - ll2=len_frag(j,1) - endif - len_cut=max0(min0(ll1*4/5,ll2)*4/5,3) - endif - write (iout,*) "Fragments",i,j," structure",istruct(i),& - istruct(j)," # contacts",& - ncont_frag_ref(ind),nsccont_frag_ref(ind),& - " lengths",len_frag(i,1),len_frag(j,1),& - " ll1",ll1," ll2",ll2," len_cut",len_cut - if ((istruct(i).eq.1 .or. istruct(j).eq.1) .and. & - nsccont_frag_ref(ind).ge.len_cut ) then - if (istruct(i).eq.1 .and. istruct(j).eq.1) then - write (iout,*) "Adding pair of helices",i,j,& - " based on SC contacts" - else - write (iout,*) "Adding helix+strand/sheet pair",i,j,& - " based on SC contacts" - endif - nfrag(2)=nfrag(2)+1 - if (icont_pair.gt.0) then - write (iout,*) "# SC contacts will be used",& - " in comparison." - isccont(nfrag(2),2)=1 - endif - if (irms_pair.gt.0) then - write (iout,*) "Fragment RMSD will be used",& - " in comparison." - irms(nfrag(2),2)=1 - endif - npiece(nfrag(2),2)=2 - ipiece(1,nfrag(2),2)=i - ipiece(2,nfrag(2),2)=j - ielecont(nfrag(2),2)=0 - n_shift(1,nfrag(2),2)=nshift_pair - n_shift(2,nfrag(2),2)=nshift_pair - nc_fragm(nfrag(2),2)=ncfrac_pair - nc_req_setf(nfrag(2),2)=ncreq_pair - else if ((istruct(i).ge.2 .and. istruct(i).le.4) & - .and. (istruct(j).ge.2 .and. istruct(i).le.4) & - .and. ncont_frag_ref(ind).ge.len_cut ) then - nfrag(2)=nfrag(2)+1 - write (iout,*) "Adding pair strands/sheets",i,j,& - " based on pp contacts" - if (icont_pair.gt.0) then - write (iout,*) "# pp contacts will be used",& - " in comparison." - ielecont(nfrag(2),2)=1 - endif - if (irms_pair.gt.0) then - write (iout,*) "Fragment RMSD will be used",& - " in comparison." - irms(nfrag(2),2)=1 - endif - npiece(nfrag(2),2)=2 - ipiece(1,nfrag(2),2)=i - ipiece(2,nfrag(2),2)=j - ielecont(nfrag(2),2)=1 - isccont(nfrag(2),2)=0 - n_shift(1,nfrag(2),2)=nshift_pair - n_shift(2,nfrag(2),2)=nshift_pair - nc_fragm(nfrag(2),2)=ncfrac_bet - nc_req_setf(nfrag(2),2)=ncreq_bet - endif - enddo - enddo - write (iout,*) "Pairs found" - do i=1,nfrag(2) - write (iout,*) ipiece(1,i,2),ipiece(2,i,2) - enddo - return - end subroutine define_pairs -!------------------------------------------------------------------------------ -! icant.f -!------------------------------------------------------------------------------ - INTEGER FUNCTION ICANT(I,J) - integer :: i,j - IF (I.GE.J) THEN - ICANT=(I*(I-1))/2+J - ELSE - ICANT=(J*(J-1))/2+I - ENDIF - RETURN - END FUNCTION ICANT -!------------------------------------------------------------------------------ -! mysort.f -!------------------------------------------------------------------------------ - subroutine imysort(n, m, mm, x, y, z, z1, z2, z3, z4, z5, z6) -! implicit none - integer :: n,m,mm - integer :: x(m,mm,n),y(n),z(n),z1(2,n),z6(n),xmin,xtemp - real(kind=8) :: z2(n),z3(n),z4(n),z5(n) - real(kind=8) :: xxtemp - integer :: i,j,k,imax - do i=1,n - xmin=x(1,1,i) - imax=i - do j=i+1,n - if (x(1,1,j).lt.xmin) then - imax=j - xmin=x(1,1,j) - endif - enddo - xxtemp=z2(imax) - z2(imax)=z2(i) - z2(i)=xxtemp - xxtemp=z3(imax) - z3(imax)=z3(i) - z3(i)=xxtemp - xxtemp=z4(imax) - z4(imax)=z4(i) - z4(i)=xxtemp - xxtemp=z5(imax) - z5(imax)=z5(i) - z5(i)=xxtemp - xtemp=y(imax) - y(imax)=y(i) - y(i)=xtemp - xtemp=z(imax) - z(imax)=z(i) - z(i)=xtemp - xtemp=z6(imax) - z6(imax)=z6(i) - z6(i)=xtemp - do j=1,2 - xtemp=z1(j,imax) - z1(j,imax)=z1(j,i) - z1(j,i)=xtemp - enddo - do j=1,m - do k=1,mm - xtemp=x(j,k,imax) - x(j,k,imax)=x(j,k,i) - x(j,k,i)=xtemp - enddo - enddo - enddo - return - end subroutine imysort -!------------------------------------------------------------------------------ -! qwolynes.f -!------------------------------------------------------------------------------- - real(kind=8) function qwolynes(ilevel,jfrag) - - use geometry_data, only:cref,nperm - use control_data, only:symetr - use energy_data, only:nnt,nct,itype -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTROL' - integer :: ilevel,jfrag,kkk - integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp - integer :: nsep=3 - real(kind=8),dimension(:),allocatable :: tempus !(maxperm) - real(kind=8) :: maxiQ !dist, - real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical :: lprn=.false. - real(kind=8) :: x !el sigm -!el sigm(x)=0.25d0*x - nperm=1 - maxiQ=0 - do i=1,symetr - nperm=i*nperm - enddo -! write (iout,*) "QWolyes: " jfrag",jfrag, -! & " ilevel",ilevel - allocate(tempus(nperm)) - do kkk=1,nperm - qq = 0.0d0 - if (ilevel.eq.0) then - if (lprn) write (iout,*) "Q computed for whole molecule" - nl=0 - do il=nnt+nsep,nct - do jl=nnt,il-nsep - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & - (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & - (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "il",il," jl",jl,& - " itype",itype(il),itype(jl) - write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM,& - " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - enddo - enddo - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else if (ilevel.eq.1) then - if (lprn) write (iout,*) "Level",ilevel," fragment",jfrag - nl=0 -! write (iout,*) "nlist_frag",nlist_frag(jfrag) - do i=2,nlist_frag(jfrag) - do j=1,i-1 - il=list_frag(i,jfrag) - jl=list_frag(j,jfrag) - if (iabs(il-jl).gt.nsep) then - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & - (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & - (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "i",i," j",j," il",il," jl",jl,& - " itype",itype(il),itype(jl) - write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM,& - " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - endif - enddo - enddo - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else if (ilevel.eq.2) then - np=npiece(jfrag,ilevel) - nl=0 - do i=2,np - ip=ipiece(i,jfrag,ilevel) - do j=1,nlist_frag(ip) - il=list_frag(j,ip) - do k=1,i-1 - kp=ipiece(k,jfrag,ilevel) - do l=1,nlist_frag(kp) - kl=list_frag(l,kp) - if (iabs(kl-il).gt.nsep) then - nl=nl+1 - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - d0ij=dsqrt((cref(1,kl,kkk)-cref(1,il,kkk))**2+ & - (cref(2,kl,kkk)-cref(2,il,kkk))**2+ & - (cref(3,kl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,kl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(kl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( & - (cref(1,kl+nres,kkk)-cref(1,il+nres,kkk))**2+ & - (cref(2,kl+nres,kkk)-cref(2,il+nres,kkk))**2+ & - (cref(3,kl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,kl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/ & - (sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "i",i," j",j," k",k," l",l," il",il,& - " kl",kl," itype",itype(il),itype(kl) - write (iout,*) " d0ij",d0ij," dij",dij," d0ijCM",& - d0ijCM," dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - endif - enddo ! l - enddo ! k - enddo ! j - enddo ! i - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else - write (iout,*)"Error: Q can be computed only for level 1 and 2." - endif - tempus(kkk)=qq - enddo - do kkk=1,nperm - if (maxiQ.le.tempus(kkk)) maxiQ=tempus(kkk) - enddo - qwolynes=1.0d0-maxiQ - deallocate(tempus) - return - end function qwolynes -!------------------------------------------------------------------------------- - real(kind=8) function sigm(x) - real(kind=8) :: x - sigm=0.25d0*x - return - end function sigm -!------------------------------------------------------------------------------- - subroutine fragment_list -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.COMPAR' - logical :: lprn=.true. - integer :: i,ilevel,j,k,jfrag - do jfrag=1,nfrag(1) - nlist_frag(jfrag)=0 - do i=1,npiece(jfrag,1) - if (lprn) write (iout,*) "jfrag=",jfrag,& - "i=",i," fragment",ifrag(1,i,jfrag),& - ifrag(2,i,jfrag) - do j=ifrag(1,i,jfrag),ifrag(2,i,jfrag) - do k=1,nlist_frag(jfrag) - if (list_frag(k,jfrag).eq.j) goto 10 - enddo - nlist_frag(jfrag)=nlist_frag(jfrag)+1 - list_frag(nlist_frag(jfrag),jfrag)=j - enddo - 10 continue - enddo - enddo - write (iout,*) "Fragment list" - do j=1,nfrag(1) - write (iout,*)"Fragment",j," list",(list_frag(k,j),& - k=1,nlist_frag(j)) - enddo - return - end subroutine fragment_list -!------------------------------------------------------------------------------- - real(kind=8) function rmscalc(ishif,i,j,jcon,lprn) - - use w_comm_local - use control_data, only:symetr - use geometry_data, only:nperm -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.CONTROL' - real(kind=8) :: przes(3),obrot(3,3) -!el real(kind=8) :: creff(3,nres*2),cc(3,nres*2) -!el logical :: iadded(nres) -!el integer :: inumber(2,nres) -!el common /ccc/ creff,cc,iadded,inumber - logical :: lprn - logical :: non_conv - integer :: ishif,i,j,jcon,idup,kkk,l,k,kk - real(kind=8) :: rminrms,rms - if (lprn) then - write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif - write (iout,*) "npiece",npiece(j,i) - call flush(iout) - endif -! write (iout,*) "symetr",symetr -! call flush(iout) - nperm=1 - do idup=1,symetr - nperm=nperm*idup - enddo -! write (iout,*) "nperm",nperm -! call flush(iout) - do kkk=1,nperm - idup=0 - do l=1,nres - iadded(l)=.false. - enddo -! write (iout,*) "kkk",kkk -! call flush(iout) - do k=1,npiece(j,i) - if (i.eq.1) then - if (lprn) then - write (iout,*) "Level 1: j=",j,"k=",k," adding fragment",& - ifrag(1,k,j),ifrag(2,k,j) - call flush(iout) - endif - call cprep(ifrag(1,k,j),ifrag(2,k,j),ishif,idup,kkk) -! write (iout,*) "Exit cprep" -! call flush(iout) -! write (iout,*) "ii=",ii - else - kk = ipiece(k,j,i) -! write (iout,*) "kk",kk," npiece",npiece(kk,1) - do l=1,npiece(kk,1) - if (lprn) then - write (iout,*) "Level",i,": j=",j,"k=",k," kk=",kk,& - " l=",l," adding fragment",& - ifrag(1,l,kk),ifrag(2,l,kk) - call flush(iout) - endif - call cprep(ifrag(1,l,kk),ifrag(2,l,kk),ishif,idup,kkk) -! write (iout,*) "After cprep" -! call flush(iout) - enddo - endif - enddo - enddo - if (lprn) then - write (iout,*) "tuszukaj" - do kkk=1,nperm - do k=1,idup - write(iout,'(5i4,2(3f10.5,5x))') i,j,k,inumber(1,k),& - inumber(2,k),(creff(l,k),l=1,3),(cc(l,k),l=1,3) - enddo - enddo - call flush(iout) - endif - rminrms=1.0d10 - do kkk=1,nperm - call fitsq(rms,cc(1,1),creff(1,1),idup,przes,obrot,non_conv) - if (non_conv) then - print *,'Error: FITSQ non-convergent, jcon',jcon,i - rms = 1.0d10 - else if (rms.lt.-1.0d-6) then - print *,'Error: rms^2 = ',rms,jcon,i - rms = 1.0d10 - else if (rms.ge.1.0d-6 .and. rms.lt.0) then - rms = 0.0d0 - endif -! write (iout,*) "rmsmin", rminrms, "rms", rms - if (rms.le.rminrms) rminrms=rms - enddo - rmscalc = dsqrt(rminrms) -! write (iout, *) "analysys", rmscalc,anatemp - return - end function rmscalc -!------------------------------------------------------------------------- - subroutine cprep(if1,if2,ishif,idup,kwa) - - use w_comm_local - use control_data, only:symetr - use geometry_data, only:nperm,cref,c -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.CONTROL' -! include 'COMMON.IOUNITS' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' - real(kind=8) :: przes(3),obrot(3,3) -!el real(kind=8) :: creff(3,nres*2),cc(3,nres*2) -!el logical :: iadded(nres) -!el integer :: inumber(2,nres) - integer :: iistrart,kwa,blar -!el common /ccc/ creff,cc,iadded,inumber - integer :: if1,if2,ishif,idup,kkk,l,m -! write (iout,*) "Calling cprep symetr",symetr," kwa",kwa - nperm=1 - do blar=1,symetr - nperm=nperm*blar - enddo -! write (iout,*) "nperm",nperm - kkk=kwa -! ii=0 - do l=if1,if2 -! write (iout,*) "l",l," iadded",iadded(l) -! call flush(iout) - if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l)) & - then - idup=idup+1 - iadded(l)=.true. - inumber(1,idup)=l - inumber(2,idup)=l+ishif - do m=1,3 - creff(m,idup)=cref(m,l,kkk) - cc(m,idup)=c(m,l+ishif) - enddo - endif - enddo - return - end subroutine cprep -!------------------------------------------------------------------------- - real(kind=8) function rmsnat(jcon) - - use control_data, only:symetr - use geometry_data, only:nperm,cref,c - use energy_data, only:itype -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.VAR' -! include 'COMMON.CONTROL' - real(kind=8) :: przes(3),obrot(3,3),cc(3,2*nres),ccref(3,2*nres) - logical :: non_conv - integer :: ishif,i,j,resprzesun,jcon,kkk,nnsup - real(kind=8) :: rminrms,rmsminsing,rms - rminrms=10.0d10 - rmsminsing=10d10 - nperm=1 - do i=1,symetr - nperm=nperm*i - enddo - do kkk=1,nperm - nnsup=0 - do i=1,nres - if (itype(i).ne.ntyp1) then - nnsup=nnsup+1 - do j=1,3 - cc(j,nnsup)=c(j,i) - ccref(j,nnsup)=cref(j,i,kkk) - enddo - endif - enddo - call fitsq(rms,cc(1,1),ccref(1,1),nnsup,przes,obrot,non_conv) - if (non_conv) then - print *,'Error: FITSQ non-convergent, jcon',jcon,i - rms=1.0d10 - else if (rms.lt.-1.0d-6) then - print *,'Error: rms^2 = ',rms,jcon,i - rms = 1.0d10 - else if (rms.ge.1.0d-6 .and. rms.lt.0) then - rms=0.0d0 - endif - if (rms.le.rminrms) rminrms=rms -! write (iout,*) "kkk",kkk," rmsnat",rms , rminrms - enddo - rmsnat = dsqrt(rminrms) -! write (iout,*) "analysys",rmsnat, anatemp -! liczenie rmsdla pojedynczego lancucha - return - end function rmsnat -!------------------------------------------------------------------------------- - subroutine define_fragments - - use geometry_data, only:rad2deg - use energy_data, only:itype - use compare_data, only:nhfrag,nbfrag,bfrag,hfrag -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.FRAG' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.HEADER' -! include 'COMMON.GEO' -! include 'COMMON.CONTACTS' -! include 'COMMON.PEPTCONT' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' - integer :: nstrand,istrand(2,nres/2) - integer :: nhairp,ihairp(2,nres/5) - character(len=16) :: strstr(4)=reshape((/'helix','hairpin',& - 'strand','strand pair'/),shape(strstr)) - integer :: j,i,ii,i1,i2,i3,i4,it1,it2,it3,it4 - - write (iout,*) 'NC_FRAC_HEL',ncfrac_hel,' NC_REQ_HEL',ncreq_hel,& - 'NC_FRAC_BET',ncfrac_bet,' NC_REQ_BET',ncreq_bet,& - 'NC_FRAC_PAIR',ncfrac_pair,' NC_REQ_PAIR',ncreq_pair,& - ' RMS_PAIR',irms_pair,' SPLIT_BET',isplit_bet - write (iout,*) 'NSHIFT_HEL',nshift_hel,' NSHIFT_BET',nshift_bet,& - ' NSHIFT_STRAND',nshift_strand,' NSHIFT_PAIR',nshift_pair - write (iout,*) 'ANGCUT_HEL',angcut_hel*rad2deg,& - ' MAXANG_HEL',angcut1_hel*rad2deg - write (iout,*) 'ANGCUT_BET',angcut_bet*rad2deg,& - ' MAXANG_BET',angcut1_bet*rad2deg - write (iout,*) 'ANGCUT_STRAND',angcut_strand*rad2deg,& - ' MAXANG_STRAND',angcut1_strand*rad2deg - write (iout,*) 'FRAC_MIN',frac_min_set -! Find secondary structure elements (helices and beta-sheets) - call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref,& - isec_ref) -! Define primary fragments. First include the helices. - nhairp=0 - nstrand=0 -! Merge helices -! AL 12/23/03 - to avoid splitting helices into very small fragments - if (merge_helices) then - write (iout,*) "Before merging helices: nhfrag",nhfrag - do i=1,nhfrag - write (2,*) hfrag(1,i),hfrag(2,i) - enddo - i=1 - do while (i.lt.nhfrag) - if (hfrag(1,i+1)-hfrag(2,i).le.1) then - nhfrag=nhfrag-1 - hfrag(2,i)=hfrag(2,i+1) - do j=i+1,nhfrag - hfrag(1,j)=hfrag(1,j+1) - hfrag(2,j)=hfrag(2,j+1) - enddo - endif - i=i+1 - enddo - write (iout,*) "After merging helices: nhfrag",nhfrag - do i=1,nhfrag - write (2,*) hfrag(1,i),hfrag(2,i) - enddo - endif - nfrag(1)=nhfrag - do i=1,nhfrag - npiece(i,1)=1 - ifrag(1,1,i)=hfrag(1,i) - ifrag(2,1,i)=hfrag(2,i) - n_shift(1,i,1)=0 - n_shift(2,i,1)=nshift_hel - ang_cut(i)=angcut_hel - ang_cut1(i)=angcut1_hel - frac_min(i)=frac_min_set - nc_fragm(i,1)=ncfrac_hel - nc_req_setf(i,1)=ncreq_hel - istruct(i)=1 - enddo - write (iout,*) "isplit_bet",isplit_bet - if (isplit_bet.gt.1) then -! Split beta-sheets into strands and store strands as primary fragments. - call split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) - do i=1,nstrand - ii=i+nfrag(1) - npiece(ii,1)=1 - ifrag(1,1,ii)=istrand(1,i) - ifrag(2,1,ii)=istrand(2,i) - n_shift(1,ii,1)=nshift_strand - n_shift(2,ii,1)=nshift_strand - ang_cut(ii)=angcut_strand - ang_cut1(ii)=angcut1_strand - frac_min(ii)=frac_min_set - nc_fragm(ii,1)=0 - nc_req_setf(ii,1)=0 - istruct(ii)=3 - enddo - nfrag(1)=nfrag(1)+nstrand - else if (isplit_bet.eq.1) then -! Split only far beta-sheets; does not split hairpins. - call find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) - call split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) - do i=1,nhairp - ii=i+nfrag(1) - npiece(ii,1)=1 - ifrag(1,1,ii)=ihairp(1,i) - ifrag(2,1,ii)=ihairp(2,i) - n_shift(1,ii,1)=nshift_bet - n_shift(2,ii,1)=nshift_bet - ang_cut(ii)=angcut_bet - ang_cut1(ii)=angcut1_bet - frac_min(ii)=frac_min_set - nc_fragm(ii,1)=ncfrac_bet - nc_req_setf(ii,1)=ncreq_bet - istruct(ii)=2 - enddo - nfrag(1)=nfrag(1)+nhairp - do i=1,nstrand - ii=i+nfrag(1) - npiece(ii,1)=1 - ifrag(1,1,ii)=istrand(1,i) - ifrag(2,1,ii)=istrand(2,i) - n_shift(1,ii,1)=nshift_strand - n_shift(2,ii,1)=nshift_strand - ang_cut(ii)=angcut_strand - ang_cut1(ii)=angcut1_strand - frac_min(ii)=frac_min_set - nc_fragm(ii,1)=0 - nc_req_setf(ii,1)=0 - istruct(ii)=3 - enddo - nfrag(1)=nfrag(1)+nstrand - else -! Do not split beta-sheets; each pair of strands is a primary element. - call find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) - do i=1,nhairp - ii=i+nfrag(1) - npiece(ii,1)=1 - ifrag(1,1,ii)=ihairp(1,i) - ifrag(2,1,ii)=ihairp(2,i) - n_shift(1,ii,1)=nshift_bet - n_shift(2,ii,1)=nshift_bet - ang_cut(ii)=angcut_bet - ang_cut1(ii)=angcut1_bet - frac_min(ii)=frac_min_set - nc_fragm(ii,1)=ncfrac_bet - nc_req_setf(ii,1)=ncreq_bet - istruct(ii)=2 - enddo - nfrag(1)=nfrag(1)+nhairp - do i=1,nbfrag - ii=i+nfrag(1) - npiece(ii,1)=2 - ifrag(1,1,ii)=bfrag(1,i) - ifrag(2,1,ii)=bfrag(2,i) - if (bfrag(3,i).lt.bfrag(4,i)) then - ifrag(1,2,ii)=bfrag(3,i) - ifrag(2,2,ii)=bfrag(4,i) - else - ifrag(1,2,ii)=bfrag(4,i) - ifrag(2,2,ii)=bfrag(3,i) - endif - n_shift(1,ii,1)=nshift_bet - n_shift(2,ii,1)=nshift_bet - ang_cut(ii)=angcut_bet - ang_cut1(ii)=angcut1_bet - frac_min(ii)=frac_min_set - nc_fragm(ii,1)=ncfrac_bet - nc_req_setf(ii,1)=ncreq_bet - istruct(ii)=4 - enddo - nfrag(1)=nfrag(1)+nbfrag - endif - write (iout,*) "The following primary fragments were found:" - write (iout,*) "Helices:",nhfrag - do i=1,nhfrag - i1=ifrag(1,1,i) - i2=ifrag(2,1,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') & - i,restyp(it1),i1,restyp(it2),i2 - enddo - write (iout,*) "Hairpins:",nhairp - do i=nhfrag+1,nhfrag+nhairp - i1=ifrag(1,1,i) - i2=ifrag(2,1,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,2x)') & - i,restyp(it1),i1,restyp(it2),i2 - enddo - write (iout,*) "Far strand pairs:",nbfrag - do i=nhfrag+nhairp+1,nhfrag+nhairp+nbfrag - i1=ifrag(1,1,i) - i2=ifrag(2,1,i) - it1=itype(i1) - it2=itype(i2) - i3=ifrag(1,2,i) - i4=ifrag(2,2,i) - it3=itype(i3) - it4=itype(i4) - write (iout,'(i3,2x,a,i4,2x,a,i4," and ",a,i4,2x,a,i4)') & - i,restyp(it1),i1,restyp(it2),i2,& - restyp(it3),i3,restyp(it4),i4 - enddo - write (iout,*) "Strands:",nstrand - do i=nhfrag+nhairp+nbfrag+1,nfrag(1) - i1=ifrag(1,1,i) - i2=ifrag(2,1,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') & - i,restyp(it1),i1,restyp(it2),i2 - enddo - call imysort(nfrag(1),2,maxpiece,ifrag(1,1,1),npiece(1,1),& - istruct(1),n_shift(1,1,1),ang_cut(1),ang_cut1(1),frac_min(1),& - nc_fragm(1,1),nc_req_setf(1,1)) - write (iout,*) "Fragments after sorting:" - do i=1,nfrag(1) - i1=ifrag(1,1,i) - i2=ifrag(2,1,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,$)') & - i,restyp(it1),i1,restyp(it2),i2 - if (npiece(i,1).eq.1) then - write (iout,'(2x,a)') strstr(istruct(i)) - else - i1=ifrag(1,2,i) - i2=ifrag(2,2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(2x,a,i4,2x,a,i4,2x,a)') & - restyp(it1),i1,restyp(it2),i2,strstr(istruct(i)) - endif - enddo - return - end subroutine define_fragments -!------------------------------------------------------------------------------ - subroutine find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' - integer :: nbfrag,bfrag(4,nres/3) - integer :: nhairp,ihairp(2,nres/5) - integer :: i,j,k - write (iout,*) "Entered find_and_remove_hairpins" - write (iout,*) "nbfrag",nbfrag - do i=1,nbfrag - write (iout,*) i,(bfrag(k,i),k=1,4) - enddo - nhairp=0 - i=1 - do while (i.le.nbfrag) - write (iout,*) "check hairpin:",i,(bfrag(j,i),j=1,4) - if (bfrag(3,i).gt.bfrag(4,i) .and. bfrag(4,i)-bfrag(2,i).lt.5) & - then - write (iout,*) "Found hairpin:",i,bfrag(1,i),bfrag(3,i) - nhairp=nhairp+1 - ihairp(1,nhairp)=bfrag(1,i) - ihairp(2,nhairp)=bfrag(3,i) - nbfrag=nbfrag-1 - do j=i,nbfrag - do k=1,4 - bfrag(k,j)=bfrag(k,j+1) - enddo - enddo - else - i=i+1 - endif - enddo - write (iout,*) "After finding hairpins:" - write (iout,*) "nhairp",nhairp - do i=1,nhairp - write (iout,*) i,ihairp(1,i),ihairp(2,i) - enddo - write (iout,*) "nbfrag",nbfrag - do i=1,nbfrag - write (iout,*) i,(bfrag(k,i),k=1,4) - enddo - return - end subroutine find_and_remove_hairpins -!------------------------------------------------------------------------------ - subroutine split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' - integer :: nbfrag,bfrag(4,nres/3) - integer :: nstrand,istrand(2,nres/2) - integer :: nhairp,ihairp(2,nres/5) - logical :: found - integer :: i,k - write (iout,*) "Entered split_beta" - write (iout,*) "nbfrag",nbfrag - do i=1,nbfrag - write (iout,*) i,(bfrag(k,i),k=1,4) - enddo - nstrand=0 - do i=1,nbfrag - write (iout,*) "calling add_strand:",i,bfrag(1,i),bfrag(2,i) - call add_strand(nstrand,istrand,nhairp,ihairp,& - bfrag(1,i),bfrag(2,i),found) - if (bfrag(3,i).lt.bfrag(4,i)) then - write (iout,*) "calling add_strand:",i,bfrag(3,i),bfrag(4,i) - call add_strand(nstrand,istrand,nhairp,ihairp,& - bfrag(3,i),bfrag(4,i),found) - else - write (iout,*) "calling add_strand:",i,bfrag(4,i),bfrag(3,i) - call add_strand(nstrand,istrand,nhairp,ihairp,& - bfrag(4,i),bfrag(3,i),found) - endif - enddo - nbfrag=0 - write (iout,*) "Strands found:",nstrand - do i=1,nstrand - write (iout,*) i,istrand(1,i),istrand(2,i) - enddo - return - end subroutine split_beta -!------------------------------------------------------------------------------ - subroutine add_strand(nstrand,istrand,nhairp,ihairp,is1,is2,found) -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'COMMON.IOUNITS' - integer :: nstrand,istrand(2,nres/2) - integer :: nhairp,ihairp(2,nres/5) - logical :: found - integer :: is1,is2,j,idelt - found=.false. - do j=1,nhairp - idelt=(ihairp(2,j)-ihairp(1,j))/6 - if (is1.lt.ihairp(2,j)-idelt.and.is2.gt.ihairp(1,j)+idelt) then - write (iout,*) "strand",is1,is2," is part of hairpin",& - ihairp(1,j),ihairp(2,j) - return - endif - enddo - do j=1,nstrand - idelt=(istrand(2,j)-istrand(1,j))/3 - if (is1.lt.istrand(2,j)-idelt.and.is2.gt.istrand(1,j)+idelt) & - then -! The strand already exists in the array; update its ends if necessary. - write (iout,*) "strand",is1,is2," found at position",j,& - ":",istrand(1,j),istrand(2,j) - istrand(1,j)=min0(istrand(1,j),is1) - istrand(2,j)=max0(istrand(2,j),is2) - return - endif - enddo -! The strand has not been found; add it to the array. - write (iout,*) "strand",is1,is2," added to the array." - found=.true. - nstrand=nstrand+1 - istrand(1,nstrand)=is1 - istrand(2,nstrand)=is2 - return - end subroutine add_strand -!------------------------------------------------------------------------------ - subroutine secondary2(lprint,lprint_sec,ncont,icont,isecstr) - - use geometry_data, only:anatemp,rad2deg,phi,nstart_sup,nend_sup - use energy_data, only:itype,maxcont - use compare_data, only:bfrag,hfrag,nbfrag,nhfrag - use compare, only:freeres -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'COMMON.IOUNITS' -! include 'COMMON.FRAG' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.CHAIN' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' - integer :: ncont,icont(2,maxcont),isec(nres,4),nsec(nres),& - isecstr(nres) - logical :: lprint,lprint_sec,not_done !el,freeres - integer :: i,j,ii1,jj1,i1,j1,ij,k,ien,ist - integer :: nstrand,nbeta,nhelix,iii1,jjj1 - real(kind=8) :: p1,p2 -!rel external freeres - character(len=1) :: csec(0:2)=reshape((/'-','E','H'/),shape(csec)) - if (lprint) then - write (iout,*) "entered secondary2",ncont - write (iout,*) "nstart_sup",nstart_sup," nend_sup",nend_sup - do i=1,ncont - write (iout,*) icont(1,i),icont(2,i) - enddo - endif - do i=1,nres - isecstr(i)=0 - enddo - nbfrag=0 - nhfrag=0 - do i=1,nres - isec(i,1)=0 - isec(i,2)=0 - nsec(i)=0 - enddo - -! 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 (i1.ge.nstart_sup .and. i1.le.nend_sup & - .and. j1.gt.nstart_sup .and. j1.le.nend_sup) then -!d write (iout,*) "parallel",i1,j1 - 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_sec) 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 - endif ! i1.ge.nstart_sup .and. i1.le.nend_sup .and. i2.gt.nstart_sup .and. i2.le.nend_sup - enddo - -! 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) then - isec(ij,nsec(ij))=nbeta - endif - enddo - - - if (lprint_sec) 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 - -!d write (iout,*) "After beta:",nbfrag -!d do i=1,nbfrag -!d write (iout,*) (bfrag(j,i),j=1,4) -!d enddo - - if (nstrand.gt.0.and.lprint_sec) 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) - 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 write (iout,*) i1,j1,not_done,p1,p2 - 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)=j1 - - do ij=ii1,j1 - nsec(ij)=-1 - enddo - if (lprint_sec) 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_sec) 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_sec) then - write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" - write(12,'(a20)') "XMacStand ribbon.mac" - endif - - if (lprint) then - - write(iout,*) 'UNRES seq:',anatemp - 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),anatemp - enddo - - endif - - do j=1,nbfrag - do k=min0(bfrag(1,j),bfrag(2,j)),max0(bfrag(1,j),bfrag(2,j)) - isecstr(k)=1 - enddo - do k=min0(bfrag(3,j),bfrag(4,j)),max0(bfrag(3,j),bfrag(4,j)) - isecstr(k)=1 - enddo - enddo - do j=1,nhfrag - do k=hfrag(1,j),hfrag(2,j) - isecstr(k)=2 - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,*) "Secondary structure" - do i=1,nres,80 - ist=i - ien=min0(i+79,nres) - write (iout,*) - write (iout,'(8(7x,i3))') (k,k=ist+9,ien,10) - write (iout,'(80a1)') (onelet(itype(k)),k=ist,ien) - write (iout,'(80a1)') (csec(isecstr(k)),k=ist,ien) - enddo - write (iout,*) - endif - return - end subroutine secondary2 -!------------------------------------------------- -! logical function freeres(i,j,nsec,isec) -! include 'DIMENSIONS' -! integer :: isec(nres,4),nsec(nres) -! integer :: i,j,k,l -! freeres=.false. -! -! 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 -!------------------------------------------------- - subroutine alloc_compar_arrays(nfrg,nlev) - - use energy_data, only:maxcont - use w_comm_local - integer :: nfrg,nlev - -!write(iout,*) "in alloc conpar arrays: nlevel=", nlevel," nfrag(1)=",nfrag(1) -!------------------------ -! commom.contacts -! common /contacts/ - allocate(nsccont_frag_ref(mmaxfrag)) !(mmaxfrag) !wham - allocate(isccont_frag_ref(2,maxcont,mmaxfrag)) !(2,maxcont,mmaxfrag) !wham -!------------------------ -! COMMON.COMPAR -! common /compar/ - allocate(rmsfrag(nfrg,nlev+1),nc_fragm(nfrg,nlev+1)) !(maxfrag,maxlevel) - allocate(qfrag(nfrg,2)) !(maxfrag,2) - allocate(rmscutfrag(2,nfrg,nlev+1)) !(2,maxfrag,maxlevel) - allocate(ang_cut(nfrg),ang_cut1(nfrg),frac_min(nfrg)) !(maxfrag) - allocate(nc_req_setf(nfrg,nlev+1),npiece(nfrg,nlev+1),& - ielecont(nfrg,nlev+1),isccont(nfrg,nlev+1),irms(nfrg,nlev+1),& - ishifft(nfrg,nlev+1),len_frag(nfrg,nlev+1)) !(maxfrag,maxlevel) - allocate(ncont_nat(2,nfrg,nlev+1)) - allocate(n_shift(2,nfrg,nlev+1)) !(2,maxfrag,maxlevel) -! allocate(nfrag(nlev)) !(maxlevel) - allocate(isnfrag(nlev+2)) !(maxlevel+1) - allocate(ifrag(2,maxpiece,nfrg)) !(2,maxpiece,maxfrag) - allocate(ipiece(maxpiece,nfrg,2:nlev+1)) !(maxpiece,maxfrag,2:maxlevel) - allocate(istruct(nfrg),iloc(nfrg),nlist_frag(nfrg)) !(maxfrag) - allocate(iclass(nlev*nfrg,nlev+1)) !(maxlevel*maxfrag,maxlevel) - allocate(list_frag(nres,nfrg)) !(maxres,maxfrag) -!------------------------ -! COMMON.PEPTCONT -! common /peptcont/ -! integer,dimension(:,:),allocatable :: icont_pept_ref !(2,maxcont) - allocate(ncont_frag_ref(mmaxfrag)) !(mmaxfrag) - allocate(icont_frag_ref(2,maxcont,mmaxfrag)) !(2,maxcont,mmaxfrag) -! integer,dimension(:),allocatable :: isec_ref !(maxres) -!------------------------ -! module w_comm_local -! common /ccc/ - allocate(creff(3,2*nres),cc(3,2*nres)) !(3,nres*2) - allocate(iadded(nres)) !(nres) - allocate(inumber(2,nres)) !(2,nres) - - -!------------------------------------------------------------------------------- - end subroutine alloc_compar_arrays -#endif -!------------------------------------------------------------------------------- - end module conform_compar - diff --git a/source/wham/control_wham.F90 b/source/wham/control_wham.F90 new file mode 100644 index 0000000..2000e0b --- /dev/null +++ b/source/wham/control_wham.F90 @@ -0,0 +1,290 @@ + module control_wham +!----------------------------------------------------------------------------- + + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! initialize_p.F +!----------------------------------------------------------------------------- + subroutine init_int_table +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + use MPI_data + include 'mpif.h' +#endif +#ifdef MP +! include 'COMMON.INFO' +#endif +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.LOCAL' +! include 'COMMON.SBRIDGE' +! include 'COMMON.IOUNITS' + logical :: scheck,lprint +#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) + +!... Determine the numbers of start and end SC-SC interaction +!... to deal with by current processor. + 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 + MyRank=MyID-(MyGroup-1)*fgProcs + call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) + if (lprint) & + write (iout,*) 'Processor',MyID,' MyRank',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 + lprint=.false. +! do i=1,maxres !el ????????? + do i=1,nres + nint_gr(i)=0 + nscp_gr(i)=0 + do j=1,maxint_gr + istart(i,1)=0 + iend(i,1)=0 + ielstart(i)=0 + ielend(i)=0 + iscpstart(i,1)=0 + iscpend(i,1)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +!d write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +!d & (ihpb(i),jhpb(i),i=1,nss) + do i=nnt,nct-1 + scheck=.false. + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +!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=int_scint+nct-i +#endif + endif +#ifdef MPI + ind_scint_old=ind_scint +#endif + enddo + 12 continue +#ifndef MPI + iatsc_s=nnt + iatsc_e=nct-1 +#endif +#ifdef MPI + if (lprint) then + write (iout,*) 'Processor',MyID,' Group',MyGroup + write (iout,*) 'iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e + endif +#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=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 (iout,*) 'Processor',MyID,' MyRank',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 +#else + iatel_s=nnt + iatel_e=nct-3 + do i=iatel_s,iatel_e + ielstart(i)=i+2 + ielend(i)=nct-1 + enddo +#endif + if (lprint) then + write (iout,'(a)') 'Electrostatic interaction array:' + do i=iatel_s,iatel_e + write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) + enddo + endif ! lprint +! 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',MyID,' MyRank',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 (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,iphi_start,iphi_end) + iphi_start=iphi_start+nnt+2 + iphi_end=iphi_end+nnt+2 + call int_bounds(nres-3,itau_start,itau_end) + itau_start=itau_start+3 + itau_end=itau_end+3 + if (lprint) then + write (iout,*) 'Processor:',MyID,& + ' loc_start',loc_start,' loc_end',loc_end,& + ' ithet_start',ithet_start,' ithet_end',ithet_end,& + ' iphi_start',iphi_start,' iphi_end',iphi_end + write (*,*) 'Processor:',MyID,& + ' loc_start',loc_start,' loc_end',loc_end,& + ' ithet_start',ithet_start,' ithet_end',ithet_end,& + ' iphi_start',iphi_start,' iphi_end',iphi_end + endif + if (fgprocs.gt.1 .and. MyID.eq.BossID) then + 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',fgprocs,& + ' fine-grain processors.' + endif +#else + loc_start=2 + loc_end=nres-1 + ithet_start=3 + ithet_end=nres + iphi_start=nnt+3 + iphi_end=nct + itau_start=4 + itau_end=nres +#endif + return + end subroutine init_int_table +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module control_wham diff --git a/source/wham/control_wham.f90 b/source/wham/control_wham.f90 deleted file mode 100644 index 2000e0b..0000000 --- a/source/wham/control_wham.f90 +++ /dev/null @@ -1,290 +0,0 @@ - module control_wham -!----------------------------------------------------------------------------- - - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! initialize_p.F -!----------------------------------------------------------------------------- - subroutine init_int_table -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -#ifdef MPI - use MPI_data - include 'mpif.h' -#endif -#ifdef MP -! include 'COMMON.INFO' -#endif -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.LOCAL' -! include 'COMMON.SBRIDGE' -! include 'COMMON.IOUNITS' - logical :: scheck,lprint -#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) - -!... Determine the numbers of start and end SC-SC interaction -!... to deal with by current processor. - 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 - MyRank=MyID-(MyGroup-1)*fgProcs - call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) - if (lprint) & - write (iout,*) 'Processor',MyID,' MyRank',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 - lprint=.false. -! do i=1,maxres !el ????????? - do i=1,nres - nint_gr(i)=0 - nscp_gr(i)=0 - do j=1,maxint_gr - istart(i,1)=0 - iend(i,1)=0 - ielstart(i)=0 - ielend(i)=0 - iscpstart(i,1)=0 - iscpend(i,1)=0 - enddo - enddo - ind_scint=0 - ind_scint_old=0 -!d write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', -!d & (ihpb(i),jhpb(i),i=1,nss) - do i=nnt,nct-1 - scheck=.false. - do ii=1,nss - if (ihpb(ii).eq.i+nres) then - scheck=.true. - jj=jhpb(ii)-nres - goto 10 - endif - enddo - 10 continue -!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=int_scint+nct-i -#endif - endif -#ifdef MPI - ind_scint_old=ind_scint -#endif - enddo - 12 continue -#ifndef MPI - iatsc_s=nnt - iatsc_e=nct-1 -#endif -#ifdef MPI - if (lprint) then - write (iout,*) 'Processor',MyID,' Group',MyGroup - write (iout,*) 'iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e - endif -#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=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 (iout,*) 'Processor',MyID,' MyRank',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 -#else - iatel_s=nnt - iatel_e=nct-3 - do i=iatel_s,iatel_e - ielstart(i)=i+2 - ielend(i)=nct-1 - enddo -#endif - if (lprint) then - write (iout,'(a)') 'Electrostatic interaction array:' - do i=iatel_s,iatel_e - write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) - enddo - endif ! lprint -! 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',MyID,' MyRank',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 (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,iphi_start,iphi_end) - iphi_start=iphi_start+nnt+2 - iphi_end=iphi_end+nnt+2 - call int_bounds(nres-3,itau_start,itau_end) - itau_start=itau_start+3 - itau_end=itau_end+3 - if (lprint) then - write (iout,*) 'Processor:',MyID,& - ' loc_start',loc_start,' loc_end',loc_end,& - ' ithet_start',ithet_start,' ithet_end',ithet_end,& - ' iphi_start',iphi_start,' iphi_end',iphi_end - write (*,*) 'Processor:',MyID,& - ' loc_start',loc_start,' loc_end',loc_end,& - ' ithet_start',ithet_start,' ithet_end',ithet_end,& - ' iphi_start',iphi_start,' iphi_end',iphi_end - endif - if (fgprocs.gt.1 .and. MyID.eq.BossID) then - 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',fgprocs,& - ' fine-grain processors.' - endif -#else - loc_start=2 - loc_end=nres-1 - ithet_start=3 - ithet_end=nres - iphi_start=nnt+3 - iphi_end=nct - itau_start=4 - itau_end=nres -#endif - return - end subroutine init_int_table -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module control_wham diff --git a/source/wham/enecalc.F90 b/source/wham/enecalc.F90 new file mode 100644 index 0000000..fd5f6ca --- /dev/null +++ b/source/wham/enecalc.F90 @@ -0,0 +1,1708 @@ + module ene_calc +!----------------------------------------------------------------------------- + use io_units + use wham_data +! + use geometry_data, only:nres + use energy_data + use control_data, only:maxthetyp1 + use energy, only:etotal,enerprint,rescale_weights +#ifdef MPI + use MPI_data +! include "mpif.h" +! include "COMMON.MPI" +#endif + implicit none +!----------------------------------------------------------------------------- +! COMMON.ALLPARM +! common /allparm/ + real(kind=8),dimension(:,:),allocatable :: ww_all !(max_ene,max_parm) ! max_eneW + real(kind=8),dimension(:),allocatable :: vbldp0_all,akp_all !(max_parm) + real(kind=8),dimension(:,:,:),allocatable :: vbldsc0_all,& + aksc_all,abond0_all !(maxbondterm,ntyp,max_parm) + real(kind=8),dimension(:,:),allocatable :: a0thet_all !(-ntyp:ntyp,max_parm) + real(kind=8),dimension(:,:,:,:,:),allocatable :: athet_all,& + bthet_all !(2,-ntyp:ntyp,-1:1,-1:1,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: polthet_all !(0:3,-ntyp:ntyp,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: gthet_all !(3,-ntyp:ntyp,max_parm) + real(kind=8),dimension(:,:),allocatable :: theta0_all,& + sig0_all,sigc0_all !(-ntyp:ntyp,max_parm) + real(kind=8),dimension(:,:,:,:,:),allocatable :: aa0thet_all +!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) + real(kind=8),dimension(:,:,:,:,:,:),allocatable :: aathet_all +!(maxtheterm,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) + real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: bbthet_all,& + ccthet_all,ddthet_all,eethet_all !(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, +! & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) + real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: ffthet_all1,& + ggthet_all1,ffthet_all2,ggthet_all2 !(maxdouble,maxdouble,maxtheterm3, +! & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,max_parm) + real(kind=8),dimension(:,:),allocatable :: dsc_all,dsc0_all !(ntyp1,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: bsc_all !(maxlob,ntyp,max_parm) + real(kind=8),dimension(:,:,:,:),allocatable :: censc_all !(3,maxlob,-ntyp:ntyp,max_parm) + real(kind=8),dimension(:,:,:,:,:),allocatable :: gaussc_all !(3,3,maxlob,-ntyp:ntyp,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: sc_parmin_all !(65,ntyp,max_parm) + real(kind=8),dimension(:,:,:,:),allocatable :: v0_all +!(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + real(kind=8),dimension(:,:,:,:,:),allocatable :: v1_all,& + v2_all !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + real(kind=8),dimension(:,:,:,:),allocatable :: vlor1_all,& + vlor2_all,vlor3_all !(maxlor,maxtor,maxtor,max_parm) + real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: v1c_all,& + v1s_all !(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: v2c_all +!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: v2s_all +!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: b1_all,b2_all !(2,-maxtor:maxtor,max_parm) + real(kind=8),dimension(:,:,:,:),allocatable :: cc_all,dd_all,& + ee_all !(2,2,-maxtor:maxtor,max_parm) + real(kind=8),dimension(:,:,:,:),allocatable :: ctilde_all,& + dtilde_all !(2,2,-maxtor:maxtor,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: b1tilde_all !(2,-maxtor:maxtor,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: app_all,bpp_all,& + ael6_all,ael3_all !(2,2,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: aad_all,& + bad_all !(ntyp,2,max_parm) + real(kind=8),dimension(:,:,:),allocatable :: aa_all,bb_all,& + augm_all,eps_all,sigma_all,r0_all,chi_all !(ntyp,ntyp,max_parm) + real(kind=8),dimension(:,:),allocatable :: chip_all,alp_all !(ntyp,max_parm) + real(kind=8),dimension(:),allocatable :: ebr_all,d0cm_all,& + akcm_all,akth_all,akct_all,v1ss_all,v2ss_all,v3ss_all !(max_parm) + real(kind=8),dimension(:,:,:,:,:),allocatable :: v1sccor_all,& + v2sccor_all !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm) + integer,dimension(:,:),allocatable :: nlob_all !(ntyp1,max_parm) + integer,dimension(:,:,:,:),allocatable :: nlor_all,& + nterm_all !(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + integer,dimension(:,:,:,:,:),allocatable :: ntermd1_all,& + ntermd2_all !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + integer,dimension(:,:),allocatable :: nbondterm_all !(ntyp,max_parm) + integer,dimension(:,:),allocatable :: ithetyp_all !(-ntyp1:ntyp1,max_parm) + integer,dimension(:),allocatable :: nthetyp_all,ntheterm_all,& + ntheterm2_all,ntheterm3_all,nsingle_all,ndouble_all,& + nntheterm_all !(max_parm) + integer,dimension(:,:,:),allocatable :: nterm_sccor_all !(-ntyp:ntyp,-ntyp:ntyp,max_parm) +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- + subroutine enecalc(islice,*) + + use names + use control_data, only:indpdb + use geometry_data, only:c,phi,theta,alph,omeg,deg2rad,anatemp,& + vbld,rad2deg,dc_norm,dc,vbld_inv + use io_base, only:gyrate!,briefout + use geometry, only:int_from_cart1 + use io_wham, only:pdboutW + use io_database, only:opentmp + use conform_compar, only:qwolynes,rmsnat +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +#ifdef MPI +! use MPI_data + include "mpif.h" +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.FFIELD" +! include "COMMON.ENEPS" +! include "COMMON.LOCAL" +! include "COMMON.WEIGHTS" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.CONTROL" +! include "COMMON.TORCNSTR" +! implicit none +#ifdef MPI + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +#endif + character(len=64) :: nazwa + character(len=80) :: bxname + character(len=3) :: liczba +!el real(kind=8) :: qwolynes +!el external qwolynes + integer :: errmsg_count,maxerrmsg_count=100 +!el real(kind=8) :: rmsnat,gyrate +!el external rmsnat,gyrate + real(kind=8) :: tole=1.0d-1 + integer i,itj,ii,iii,j,k,l,licz + integer ir,ib,ipar,iparm + integer iscor,islice + real(kind=4) :: csingle(3,nres*2) + real(kind=8) :: energ + real(kind=8) :: temp +!el integer ilen,iroof +!el external ilen,iroof + real(kind=8) :: energia(0:n_ene),rmsdev,efree,eini +!el real(kind=8) :: energia(0:max_ene),rmsdev,efree,eini + real(kind=8) :: fT(6),quot,quotl,kfacl,kfac=2.4d0,T0=3.0d2 + real(kind=8) :: tt + integer :: snk_p(MaxR,MaxT_h,nParmSet)!Max_parm) + logical :: lerr + character(len=64) :: bprotfile_temp + +! integer :: rec + integer,dimension(0:nprocs) :: scount_ +!el real(kind=8) :: rmsnat + + rescale_mode=rescale_modeW + + call opentmp(islice,ientout,bprotfile_temp) + iii=0 + ii=0 +!el +! iparm=1 + errmsg_count=0 + write (iout,*) "enecalc: nparmset ",nparmset +#ifdef MPI + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + snk_p(i,ib,iparm)=0 + enddo + enddo + enddo + do i=indstart(me1),indend(me1) +write(iout,*)"enecalc_ i indstart",i,indstart(me1),indend(me1) +#else + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + snk(i,ib,iparm)=0 + enddo + enddo + enddo + do i=1,ntot +write(iout,*)"enecalc_ i ntot",i,ntot +#endif + read(ientout,rec=i,err=101) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,(q(j,iii+1),j=1,nQ),iR,ib,ipar +!el debug +!write(iout,*)"co wczytuje" +! write(iout,*)((csingle(l,k),l=1,3),k=1,nres),& +! ((csingle(l,k+nres),l=1,3),k=nnt,nct),& +! nss,(ihpb(k),jhpb(k),k=1,nss),& +! eini,efree,rmsdev,(q(j,iii+1),j=1,nQ),iR,ib,ipar +!el -------- + +!write(iout,*)"ipar",ib,ipar,1.0d0/(beta_h(ib,ipar)*1.987D-3) + if (indpdb.gt.0) then + do k=1,nres + do l=1,3 + c(l,k)=csingle(l,k) + enddo + enddo + do k=nnt,nct + do l=1,3 + c(l,k+nres)=csingle(l,k+nres) + enddo + enddo + anatemp= 1.0d0/(beta_h(ib,ipar)*1.987D-3) + q(nQ+1,iii+1)=rmsnat(iii+1) + endif + q(nQ+2,iii+1)=gyrate(iii+1) +! write(iout,*)"wczyt",anatemp,q(nQ+2,iii+1) !el +! fT=T0*beta_h(ib,ipar)*1.987D-3 +! ft=2.0d0/(1.0d0+1.0d0/(T0*beta_h(ib,ipar)*1.987D-3)) +! EL start old rescale +! if (rescale_modeW.eq.1) then +! quot=1.0d0/(T0*beta_h(ib,ipar)*1.987D-3) +!#if defined(FUNCTH) +! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) +! ft(6)=(320.0+80.0*dtanh((tt-320.0)/80.0))/320.0 +!#elif defined(FUNCT) +! ft(6)=quot +!#else +! ft(6)=1.0d0 +!#endif +! quotl=1.0d0 +! kfacl=1.0d0 +! do l=1,5 +! quotl=quotl*quot +! kfacl=kfacl*kfac +! fT(l)=kfacl/(kfacl-1.0d0+quotl) +! enddo +! else if (rescale_modeW.eq.2) then +! quot=1.0d0/(T0*beta_h(ib,ipar)*1.987D-3) +!#if defined(FUNCTH) +! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) +! ft(6)=(320.0+80.0*dtanh((tt-320.0)/80.0))/320.0 +!#elif defined(FUNCT) +! ft(6)=quot +!#else +! ft(6)=1.0d0 +!#endif +! quotl=1.0d0 +! do l=1,5 +! quotl=quotl*quot +! fT(l)=1.12692801104297249644d0/ & +! dlog(dexp(quotl)+dexp(-quotl)) +! enddo +! else if (rescale_modeW.eq.0) then +! do l=1,5 +! fT(l)=1.0d0 +! enddo +! else +! write (iout,*) "Error in ECECALC: wrong RESCALE_MODE",& +! rescale_modeW +! call flush(iout) +! return 1 +! endif +!EL end old rescele +! write (iout,*) "T",1.0d0/(beta_h(ib,ipar)*1.987D-3)," T0",T0, +! & " kfac",kfac,"quot",quot," fT",fT +#ifdef DEBUG + write(iout,*)"weights" + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& + wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& + wtor_d,wsccor,wbond +#endif + + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + call int_from_cart1(.false.) + ii=ii+1 + +! call rescale_weights(1.0d0/(beta_h(ib,ipar)*1.987D-3)) + do iparm=1,nparmset +#ifdef DEBUG + write (iout,*) "before restore w=",1.0d0/(beta_h(ib,ipar)*1.987D-3) + write(iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& + wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& + wtor_d,wsccor,wbond +#endif + call restore_parm(iparm) + call rescale_weights(1.0d0/(beta_h(ib,ipar)*1.987D-3)) +#ifdef DEBUG + write (iout,*) "before etot w=",1.0d0/(beta_h(ib,ipar)*1.987D-3) + write(iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& + wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& + wtor_d,wsccor,wbond +#endif +! call etotal(energia(0),fT) + call etotal(energia(0)) +!write(iout,*)"check c and dc after etotal",1.0d0/(0.001987*beta_h(ib,ipar)) +!do k=1,2*nres+2 +!write(iout,*)k,"c=",(c(l,k),l=1,3) +!write(iout,*)k,"dc=",(dc(l,k),l=1,3) +!write(iout,*)k,"dc_norm=",(dc_norm(l,k),l=1,3) +!enddo +!do k=1,nres*2 +!write(iout,*)k,"vbld=",vbld(k) +!write(iout,*)k,"vbld_inv=",vbld_inv(k) +!enddo + +!write(iout,*)"energia",(energia(j),j=0,n_ene) +!write(iout,*)"enerprint tuz po call etotal" + call enerprint(energia(0)) +#ifdef DEBUG + write (iout,*) "Conformation",i + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) +! call enerprint(energia(0),fT) + call enerprint(energia(0)) + write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) + write (iout,*) "ftors",ftors +!el call briefout(i,energia(0)) + temp=1.0d0/(beta_h(ib,ipar)*1.987D-3) + write (iout,*) "temp", temp + call pdboutW(i,temp,energia(0),energia(0),0.0d0,0.0d0) +#endif + if (energia(0).ge.1.0d20) then + write (iout,*) "NaNs detected in some of the energy",& + " components for conformation",ii+1 + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" +! call intout +! call pdboutW(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,*) "The components of the energy are:" +! call enerprint(energia(0),fT) + call enerprint(energia(0)) + write (iout,*) & + "This conformation WILL NOT be added to the database." + call flush(iout) + goto 121 + else +#ifdef DEBUG + if (ipar.eq.iparm) write (iout,*) i,iparm,& + 1.0d0/(beta_h(ib,ipar)*1.987D-3),eini,energia(0) +#endif + if (ipar.eq.iparm .and. einicheck.gt.0 .and. & + dabs(eini-energia(0)).gt.tole) then + if (errmsg_count.le.maxerrmsg_count) then + write (iout,'(2a,2e15.5,a,2i8,a,f8.1)') & + "Warning: energy differs remarkably from ",& + " the value read in: ",energia(0),eini," point",& + iii+1,indstart(me1)+iii," T",& + 1.0d0/(1.987D-3*beta_h(ib,ipar)) +! call intout + call pdboutW(indstart(me1)+iii,& + 1.0d0/(1.987D-3*beta_h(ib,ipar)),& + energia(0),eini,0.0d0,0.0d0) + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" +! call intout +! call pdboutW(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + call enerprint(energia(0)) +! call enerprint(energia(0),fT) + errmsg_count=errmsg_count+1 + if (errmsg_count.gt.maxerrmsg_count) & + write (iout,*) "Too many warning messages" + if (einicheck.gt.1) then + write (iout,*) "Calculation stopped." + call flush(iout) +#ifdef MPI + call MPI_Abort(WHAM_COMM,IERROR,ERRCODE) +#endif + call flush(iout) + return 1 + endif + endif + endif + potE(iii+1,iparm)=energia(0) + do k=1,21 + enetb(k,iii+1,iparm)=energia(k) + enddo +! write (iout,'(2i5,21f8.2)') "debug",k,iii+1,(enetb(k,iii+1,iparm),k=1,21) +! write (iout,*) "debug",k,iii+1,(enetb(k,iii+1,iparm),k=1,21) +#ifdef DEBUG + write (iout,'(2i5,f10.1,3e15.5)') i,iii,& + 1.0d0/(beta_h(ib,ipar)*1.987D-3),energia(0),eini,efree +! call enerprint(energia(0),fT) +#endif +#ifdef DEBUG + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(8f10.5)') (q(k,iii+1),k=1,nQ) + write (iout,'(f10.5,i10)') rmsdev,iscor +! call enerprint(energia(0),fT) + call enerprint(energia(0)) + call pdboutW(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) +#endif + endif + + enddo ! iparm + + iii=iii+1 + if (q(1,iii).le.0.0d0 .and. indpdb.gt.0) q(1,iii)=qwolynes(0,0) + write (ientout,rec=iii) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + potE(iii,ipar),efree,rmsdev,(q(k,iii),k=1,nQ),iR,ib,ipar +! write (iout,'(2i5,2e15.5)') ii,iii,potE(iii,ipar),efree +#ifdef MPI + if (separate_parset) then + snk_p(iR,ib,1)=snk_p(iR,ib,1)+1 + else + snk_p(iR,ib,ipar)=snk_p(iR,ib,ipar)+1 + endif +! write (iout,*) "iii",iii," iR",iR," ib",ib," ipar",ipar, +! & " snk",snk_p(iR,ib,ipar) +#else + snk(iR,ib,ipar,islice)=snk(iR,ib,ipar,islice)+1 +#endif + 121 continue + enddo +#ifdef MPI + scount(me)=iii + write (iout,*) "Me",me," scount",scount(me) + call flush(iout) +! Master gathers updated numbers of conformations written by all procs. + call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount_(0), 1, & + MPI_INTEGER, WHAM_COMM, IERROR) + indstart(0)=1 + indend(0)=scount_(0) + do i=1, Nprocs-1 + indstart(i)=indend(i-1)+1 + indend(i)=indstart(i)+scount_(i)-1 + enddo + write (iout,*) + write (iout,*) "Revised conformation counts" + do i=0,nprocs1-1 + write (iout,'(a,i5,a,i7,a,i7,a,i7)') & + "Processor",i," indstart",indstart(i),& + " indend",indend(i)," count",scount_(i) + enddo + call flush(iout) + call MPI_AllReduce(snk_p(1,1,1),snk(1,1,1,islice),& + MaxR*MaxT_h*nParmSet,& + MPI_INTEGER,MPI_SUM,WHAM_COMM,IERROR) +#endif + stot(islice)=0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + stot(islice)=stot(islice)+snk(i,ib,iparm,islice) + enddo + enddo + enddo + write (iout,*) "Revised SNK" + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + write (iout,'("Param",i3," Temp",f6.1,3x,32i8)') & + iparm,1.0d0/(1.987D-3*beta_h(ib,iparm)),& + (snk(i,ib,iparm,islice),i=1,nR(ib,iparm)) + write (iout,*) "snk_p",(snk_p(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo + write (iout,'("Total",i10)') stot(islice) + call flush(iout) + do i=0,nprocs + scount(i)=scount_(i) + enddo + return + 101 write (iout,*) "Error in scratchfile." + call flush(iout) +!el#undef DEBUG + return 1 + end subroutine enecalc +!------------------------------------------------------------------------------ + logical function conf_check(ii,iprint) + + use geometry_data, only:c,phi,theta,alph,omeg,deg2rad,rad2deg,vbld + use geometry, only:int_from_cart1 +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +#ifdef MPI +! use MPI_data + include "mpif.h" +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.FFIELD" +! include "COMMON.ENEPS" +! include "COMMON.LOCAL" +! include "COMMON.WEIGHTS" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.CONTROL" +! include "COMMON.TORCNSTR" +! implicit none +#ifdef MPI + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +#endif + integer :: j,k,l,ii,itj,iprint + if (.not.check_conf) then + conf_check=.true. + return + endif + call int_from_cart1(.false.) + do j=nnt+1,nct + if (itype(j-1).ne.ntyp1 .and. itype(j).ne.ntyp1 .and. & + (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0)) then + if (iprint.gt.0) & + write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),& + " for conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) & + "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + enddo + do j=nnt,nct + itj=itype(j) + if (itype(j).ne.10 .and.itype(j).ne.ntyp1 .and. & + (vbld(nres+j)-dsc(iabs(itj))).gt.2.0d0) then + if (iprint.gt.0) & + write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j),& + " for conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) & + "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + enddo + do j=3,nres + if (theta(j).le.0.0d0) then + if (iprint.gt.0) & + write (iout,*) "Zero theta angle(s) in conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) & + "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad + enddo + conf_check=.true. +! write (iout,*) "conf_check passed",ii + return + end function conf_check +!----------------------------------------------------------------------------- +! store_parm.F +!----------------------------------------------------------------------------- + subroutine store_parm(iparm) +! +! Store parameters of set IPARM +! valence angles and the side chains and energy parameters. +! +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' +! include 'COMMON.SBRIDGE' +! include 'COMMON.SCROT' +! include 'COMMON.SCCOR' +! include 'COMMON.ALLPARM' + integer :: i,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii + + call alloc_enecalc_arrays(iparm) +!el allocate(ww_all(n_ene,iparm)) +! Store weights + ww_all(1,iparm)=wsc + ww_all(2,iparm)=wscp + ww_all(3,iparm)=welec + ww_all(4,iparm)=wcorr + ww_all(5,iparm)=wcorr5 + ww_all(6,iparm)=wcorr6 + ww_all(7,iparm)=wel_loc + ww_all(8,iparm)=wturn3 + ww_all(9,iparm)=wturn4 + ww_all(10,iparm)=wturn6 + ww_all(11,iparm)=wang + ww_all(12,iparm)=wscloc + ww_all(13,iparm)=wtor + ww_all(14,iparm)=wtor_d + ww_all(15,iparm)=wstrain + ww_all(16,iparm)=wvdwpp + ww_all(17,iparm)=wbond + ww_all(19,iparm)=wsccor +! Store bond parameters + vbldp0_all(iparm)=vbldp0 + akp_all(iparm)=akp + do i=1,ntyp + nbondterm_all(i,iparm)=nbondterm(i) + do j=1,nbondterm(i) + vbldsc0_all(j,i,iparm)=vbldsc0(j,i) + aksc_all(j,i,iparm)=aksc(j,i) + abond0_all(j,i,iparm)=abond0(j,i) + enddo + enddo +! Store bond angle parameters +#ifdef CRYST_THETA + do i=-ntyp,ntyp + a0thet_all(i,iparm)=a0thet(i) + do ichir1=-1,1 + do ichir2=-1,1 + do j=1,2 + athet_all(j,i,ichir1,ichir2,iparm)=athet(j,i,ichir1,ichir2) + bthet_all(j,i,ichir1,ichir2,iparm)=bthet(j,i,ichir1,ichir2) + enddo + enddo + enddo + do j=0,3 + polthet_all(j,i,iparm)=polthet(j,i) + enddo + do j=1,3 + gthet_all(j,i,iparm)=gthet(j,i) + enddo + theta0_all(i,iparm)=theta0(i) + sig0_all(i,iparm)=sig0(i) + sigc0_all(i,iparm)=sigc0(i) + enddo +#else + nthetyp_all(iparm)=nthetyp + ntheterm_all(iparm)=ntheterm + ntheterm2_all(iparm)=ntheterm2 + ntheterm3_all(iparm)=ntheterm3 + nsingle_all(iparm)=nsingle + ndouble_all(iparm)=ndouble + nntheterm_all(iparm)=nntheterm + do i=-ntyp,ntyp + ithetyp_all(i,iparm)=ithetyp(i) + enddo + do iblock=1,2 + do i=-maxthetyp1,maxthetyp1 + do j=-maxthetyp1,maxthetyp1 + do k=-maxthetyp1,maxthetyp1 + aa0thet_all(i,j,k,iblock,iparm)=aa0thet(i,j,k,iblock) + do l=1,ntheterm + aathet_all(l,i,j,k,iblock,iparm)=aathet(l,i,j,k,iblock) + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet_all(m,l,i,j,k,iblock,iparm)= & + bbthet(m,l,i,j,k,iblock) + ccthet_all(m,l,i,j,k,iblock,iparm)= & + ccthet(m,l,i,j,k,iblock) + ddthet_all(m,l,i,j,k,iblock,iparm)= & + ddthet(m,l,i,j,k,iblock) + eethet_all(m,l,i,j,k,iblock,iparm)= & + eethet(m,l,i,j,k,iblock) + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + if (iblock.eq.1) then + ffthet_all1(mm,m,l,i,j,k,iparm)=& + ffthet(mm,m,l,i,j,k,iblock) + ggthet_all1(mm,m,l,i,j,k,iparm)=& + ggthet(mm,m,l,i,j,k,iblock) + else + ffthet_all2(mm,m,l,i,j,k,iparm)=& + ffthet(mm,m,l,i,j,k,iblock) + ggthet_all2(mm,m,l,i,j,k,iparm)=& + ggthet(mm,m,l,i,j,k,iblock) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo +#endif +#ifdef CRYST_SC +! Store the sidechain rotamer parameters + do i=-ntyp,ntyp + iii=iabs(i) +!! write (iout,*) i,"storeparm1" + if (i.eq.0) cycle + nlob_all(iii,iparm)=nlob(iii) + do j=1,nlob(iii) + bsc_all(j,iii,iparm)=bsc(j,iii) + do k=1,3 + censc_all(k,j,i,iparm)=censc(k,j,i) + enddo + do k=1,3 + do l=1,3 + gaussc_all(l,k,j,i,iparm)=gaussc(l,k,j,i) + enddo + enddo + enddo + enddo +#else + do i=1,ntyp + do j=1,65 + sc_parmin_all(j,i,iparm)=sc_parmin(j,i) + enddo + enddo +#endif +! Store the torsional parameters + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + v0_all(i,j,iblock,iparm)=v0(i,j,iblock) + nterm_all(i,j,iblock,iparm)=nterm(i,j,iblock) + nlor_all(i,j,iblock,iparm)=nlor(i,j,iblock) + do k=1,nterm(i,j,iblock) + v1_all(k,i,j,iblock,iparm)=v1(k,i,j,iblock) + v2_all(k,i,j,iblock,iparm)=v2(k,i,j,iblock) + enddo + do k=1,nlor(i,j,iblock) + vlor1_all(k,i,j,iparm)=vlor1(k,i,j) + vlor2_all(k,i,j,iparm)=vlor2(k,i,j) + vlor3_all(k,i,j,iparm)=vlor3(k,i,j) + enddo + enddo + enddo + enddo +! Store the double torsional parameters + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + ntermd1_all(i,j,k,iblock,iparm)=ntermd_1(i,j,k,iblock) + ntermd2_all(i,j,k,iblock,iparm)=ntermd_2(i,j,k,iblock) + do l=1,ntermd_1(i,j,k,iblock) + v1c_all(1,l,i,j,k,iblock,iparm)=v1c(1,l,i,j,k,iblock) + v1c_all(2,l,i,j,k,iblock,iparm)=v1c(2,l,i,j,k,iblock) + v2c_all(1,l,i,j,k,iblock,iparm)=v2c(1,l,i,j,k,iblock) + v2c_all(2,l,i,j,k,iblock,iparm)=v2c(2,l,i,j,k,iblock) + enddo + do l=1,ntermd_2(i,j,k,iblock) + do m=1,ntermd_2(i,j,k,iblock) + v2s_all(l,m,i,j,k,iblock,iparm)=v2s(l,m,i,j,k,iblock) + enddo + enddo + enddo + enddo + enddo + enddo +! Store parameters of the cumulants + do i=-nloctyp,nloctyp + do j=1,2 + b1_all(j,i,iparm)=b1(j,i) + b1tilde_all(j,i,iparm)=b1tilde(j,i) + b2_all(j,i,iparm)=b2(j,i) + enddo + do j=1,2 + do k=1,2 + cc_all(k,j,i,iparm)=cc(k,j,i) + ctilde_all(k,j,i,iparm)=ctilde(k,j,i) + dd_all(k,j,i,iparm)=dd(k,j,i) + dtilde_all(k,j,i,iparm)=dtilde(k,j,i) + ee_all(k,j,i,iparm)=ee(k,j,i) + enddo + enddo + enddo +! Store the parameters of electrostatic interactions + do i=1,2 + do j=1,2 + app_all(j,i,iparm)=app(j,i) + bpp_all(j,i,iparm)=bpp(j,i) + ael6_all(j,i,iparm)=ael6(j,i) + ael3_all(j,i,iparm)=ael3(j,i) + enddo + enddo +! Store sidechain parameters + do i=1,ntyp + do j=1,ntyp + aa_all(j,i,iparm)=aa(j,i) + bb_all(j,i,iparm)=bb(j,i) + r0_all(j,i,iparm)=r0(j,i) + sigma_all(j,i,iparm)=sigma(j,i) + chi_all(j,i,iparm)=chi(j,i) + augm_all(j,i,iparm)=augm(j,i) + eps_all(j,i,iparm)=eps(j,i) + enddo + enddo + do i=1,ntyp + chip_all(i,iparm)=chip(i) + alp_all(i,iparm)=alp(i) + enddo +! Store the SCp parameters + do i=1,ntyp + do j=1,2 + aad_all(i,j,iparm)=aad(i,j) + bad_all(i,j,iparm)=bad(i,j) + enddo + enddo +! Store disulfide-bond parameters + ebr_all(iparm)=ebr + d0cm_all(iparm)=d0cm + akcm_all(iparm)=akcm + akth_all(iparm)=akth + akct_all(iparm)=akct + v1ss_all(iparm)=v1ss + v2ss_all(iparm)=v2ss + v3ss_all(iparm)=v3ss +! Store SC-backbone correlation parameters + do i=-nsccortyp,nsccortyp + do j=-nsccortyp,nsccortyp + + nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i) +! do i=1,20 +! do j=1,20 + do l=1,3 + do k=1,nterm_sccor(j,i) + v1sccor_all(k,l,j,i,iparm)=v1sccor(k,l,j,i) + v2sccor_all(k,l,j,i,iparm)=v2sccor(k,l,j,i) + enddo + enddo + enddo + enddo +write(iout,*)"end of store_parm" + return + end subroutine store_parm +!-------------------------------------------------------------------------- + subroutine restore_parm(iparm) +! +! Store parameters of set IPARM +! valence angles and the side chains and energy parameters. +! +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' +! include 'COMMON.SBRIDGE' +! include 'COMMON.SCROT' +! include 'COMMON.SCCOR' +! include 'COMMON.ALLPARM' + integer :: i,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii + +! Restore weights + wsc=ww_all(1,iparm) + wscp=ww_all(2,iparm) + welec=ww_all(3,iparm) + wcorr=ww_all(4,iparm) + wcorr5=ww_all(5,iparm) + wcorr6=ww_all(6,iparm) + wel_loc=ww_all(7,iparm) + wturn3=ww_all(8,iparm) + wturn4=ww_all(9,iparm) + wturn6=ww_all(10,iparm) + wang=ww_all(11,iparm) + wscloc=ww_all(12,iparm) + wtor=ww_all(13,iparm) + wtor_d=ww_all(14,iparm) + wstrain=ww_all(15,iparm) + wvdwpp=ww_all(16,iparm) + wbond=ww_all(17,iparm) + wsccor=ww_all(19,iparm) +! Restore bond parameters + vbldp0=vbldp0_all(iparm) + akp=akp_all(iparm) + do i=1,ntyp + nbondterm(i)=nbondterm_all(i,iparm) + do j=1,nbondterm(i) + vbldsc0(j,i)=vbldsc0_all(j,i,iparm) + aksc(j,i)=aksc_all(j,i,iparm) + abond0(j,i)=abond0_all(j,i,iparm) + enddo + enddo +! Restore bond angle parameters +#ifdef CRYST_THETA + do i=-ntyp,ntyp + a0thet(i)=a0thet_all(i,iparm) + do ichir1=-1,1 + do ichir2=-1,1 + do j=1,2 + athet(j,i,ichir1,ichir2)=athet_all(j,i,ichir1,ichir2,iparm) + bthet(j,i,ichir1,ichir2)=bthet_all(j,i,ichir1,ichir2,iparm) + enddo + enddo + enddo + do j=0,3 + polthet(j,i)=polthet_all(j,i,iparm) + enddo + do j=1,3 + gthet(j,i)=gthet_all(j,i,iparm) + enddo + theta0(i)=theta0_all(i,iparm) + sig0(i)=sig0_all(i,iparm) + sigc0(i)=sigc0_all(i,iparm) + enddo +#else + nthetyp=nthetyp_all(iparm) + ntheterm=ntheterm_all(iparm) + ntheterm2=ntheterm2_all(iparm) + ntheterm3=ntheterm3_all(iparm) + nsingle=nsingle_all(iparm) + ndouble=ndouble_all(iparm) + nntheterm=nntheterm_all(iparm) + do i=-ntyp,ntyp + ithetyp(i)=ithetyp_all(i,iparm) + enddo + do iblock=1,2 + do i=-maxthetyp1,maxthetyp1 + do j=-maxthetyp1,maxthetyp1 + do k=-maxthetyp1,maxthetyp1 + aa0thet(i,j,k,iblock)=aa0thet_all(i,j,k,iblock,iparm) + do l=1,ntheterm + aathet(l,i,j,k,iblock)=aathet_all(l,i,j,k,iblock,iparm) + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet(m,l,i,j,k,iblock)= & + bbthet_all(m,l,i,j,k,iblock,iparm) + ccthet(m,l,i,j,k,iblock)= & + ccthet_all(m,l,i,j,k,iblock,iparm) + ddthet(m,l,i,j,k,iblock)= & + ddthet_all(m,l,i,j,k,iblock,iparm) + eethet(m,l,i,j,k,iblock)= & + eethet_all(m,l,i,j,k,iblock,iparm) + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + if (iblock.eq.1) then + ffthet(mm,m,l,i,j,k,iblock)= & + ffthet_all1(mm,m,l,i,j,k,iparm) + ggthet(mm,m,l,i,j,k,iblock)= & + ggthet_all1(mm,m,l,i,j,k,iparm) + else + ffthet(mm,m,l,i,j,k,iblock)= & + ffthet_all2(mm,m,l,i,j,k,iparm) + ggthet(mm,m,l,i,j,k,iblock)= & + ggthet_all2(mm,m,l,i,j,k,iparm) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo +#endif +! Restore the sidechain rotamer parameters +#ifdef CRYST_SC + do i=-ntyp,ntyp + if (i.eq.0) cycle + iii=iabs(i) + nlob(iii)=nlob_all(iii,iparm) + do j=1,nlob(iii) + bsc(j,iii)=bsc_all(j,iii,iparm) + do k=1,3 + censc(k,j,i)=censc_all(k,j,i,iparm) + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=gaussc_all(l,k,j,i,iparm) + enddo + enddo + enddo + enddo +#else + do i=1,ntyp + do j=1,65 + sc_parmin(j,i)=sc_parmin_all(j,i,iparm) + enddo + enddo +#endif +! Restore the torsional parameters + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + v0(i,j,iblock)=v0_all(i,j,iblock,iparm) + nterm(i,j,iblock)=nterm_all(i,j,iblock,iparm) + nlor(i,j,iblock)=nlor_all(i,j,iblock,iparm) + do k=1,nterm(i,j,iblock) + v1(k,i,j,iblock)=v1_all(k,i,j,iblock,iparm) + v2(k,i,j,iblock)=v2_all(k,i,j,iblock,iparm) + enddo + do k=1,nlor(i,j,iblock) + vlor1(k,i,j)=vlor1_all(k,i,j,iparm) + vlor2(k,i,j)=vlor2_all(k,i,j,iparm) + vlor3(k,i,j)=vlor3_all(k,i,j,iparm) + enddo + enddo + enddo + enddo +! Restore the double torsional parameters + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + ntermd_1(i,j,k,iblock)=ntermd1_all(i,j,k,iblock,iparm) + ntermd_2(i,j,k,iblock)=ntermd2_all(i,j,k,iblock,iparm) + do l=1,ntermd_1(i,j,k,iblock) + v1c(1,l,i,j,k,iblock)=v1c_all(1,l,i,j,k,iblock,iparm) + v1c(2,l,i,j,k,iblock)=v1c_all(2,l,i,j,k,iblock,iparm) + v2c(1,l,i,j,k,iblock)=v2c_all(1,l,i,j,k,iblock,iparm) + v2c(2,l,i,j,k,iblock)=v2c_all(2,l,i,j,k,iblock,iparm) + enddo + do l=1,ntermd_2(i,j,k,iblock) + do m=1,ntermd_2(i,j,k,iblock) + v2s(l,m,i,j,k,iblock)=v2s_all(l,m,i,j,k,iblock,iparm) + enddo + enddo + enddo + enddo + enddo + enddo +! Restore parameters of the cumulants + do i=-nloctyp,nloctyp + do j=1,2 + b1(j,i)=b1_all(j,i,iparm) + b1tilde(j,i)=b1tilde_all(j,i,iparm) + b2(j,i)=b2_all(j,i,iparm) + enddo + do j=1,2 + do k=1,2 + cc(k,j,i)=cc_all(k,j,i,iparm) + ctilde(k,j,i)=ctilde_all(k,j,i,iparm) + dd(k,j,i)=dd_all(k,j,i,iparm) + dtilde(k,j,i)=dtilde_all(k,j,i,iparm) + ee(k,j,i)=ee_all(k,j,i,iparm) + enddo + enddo + enddo +! Restore the parameters of electrostatic interactions + do i=1,2 + do j=1,2 + app(j,i)=app_all(j,i,iparm) + bpp(j,i)=bpp_all(j,i,iparm) + ael6(j,i)=ael6_all(j,i,iparm) + ael3(j,i)=ael3_all(j,i,iparm) + enddo + enddo +! Restore sidechain parameters + do i=1,ntyp + do j=1,ntyp + aa(j,i)=aa_all(j,i,iparm) + bb(j,i)=bb_all(j,i,iparm) + r0(j,i)=r0_all(j,i,iparm) + sigma(j,i)=sigma_all(j,i,iparm) + chi(j,i)=chi_all(j,i,iparm) + augm(j,i)=augm_all(j,i,iparm) + eps(j,i)=eps_all(j,i,iparm) + enddo + enddo + do i=1,ntyp + chip(i)=chip_all(i,iparm) + alp(i)=alp_all(i,iparm) + enddo +! Restore the SCp parameters + do i=1,ntyp + do j=1,2 + aad(i,j)=aad_all(i,j,iparm) + bad(i,j)=bad_all(i,j,iparm) + enddo + enddo +! Restore disulfide-bond parameters + ebr=ebr_all(iparm) + d0cm=d0cm_all(iparm) + akcm=akcm_all(iparm) + akth=akth_all(iparm) + akct=akct_all(iparm) + v1ss=v1ss_all(iparm) + v2ss=v2ss_all(iparm) + v3ss=v3ss_all(iparm) +! Restore SC-backbone correlation parameters + do i=-nsccortyp,nsccortyp + do j=-nsccortyp,nsccortyp + + nterm_sccor(j,i)=nterm_sccor_all(j,i,iparm) + do l=1,3 + do k=1,nterm_sccor(j,i) + v1sccor(k,l,j,i)=v1sccor_all(k,l,j,i,iparm) + v2sccor(k,l,j,i)=v2sccor_all(k,l,j,i,iparm) + enddo + enddo + enddo + enddo + return + end subroutine restore_parm +!-------------------------------------------------------------------------- +! make_ensemble1.F +!-------------------------------------------------------------------------- + subroutine make_ensembles(islice,*) +! construct the conformational ensembles at REMD temperatures + use geometry_data, only:c + use io_base, only:ilen + use io_wham, only:pdboutW +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" +! include "COMMON.MPI" + integer :: ierror,errcode,status(MPI_STATUS_SIZE) +#endif +! include "COMMON.IOUNITS" +! include "COMMON.CONTROL" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.FFIELD" +! include "COMMON.INTERACT" +! include "COMMON.SBRIDGE" +! include "COMMON.CHAIN" +! include "COMMON.PROTFILES" +! include "COMMON.PROT" + real(kind=4) :: csingle(3,nres*2) + real(kind=8),dimension(6) :: fT,fTprim,fTbis + real(kind=8) :: quot,quotl1,quotl,kfacl,& + eprim,ebis,temper,kfac=2.4d0,T0=300.0d0 + real(kind=8) :: etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors,& + escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,& + eello_turn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt + integer :: i,ii,ik,iproc,iscor,j,k,l,ib,iparm,iprot,nlist + real(kind=8) :: qfree,sumprob,eini,efree,rmsdev + character(len=80) :: bxname + character(len=2) :: licz1,licz2 + character(len=3) :: licz3,licz4 + character(len=5) :: ctemper +!el integer ilen +!el external ilen + real(kind=4) :: Fdimless(MaxStr),Fdimless_(MaxStr) + real(kind=8) :: enepot(MaxStr) + integer :: iperm(MaxStr) + integer :: islice + integer,dimension(0:nprocs) :: scount_ + +#ifdef MPI + if (me.eq.Master) then +#endif + write (licz2,'(bz,i2.2)') islice + if (nslice.eq.1) then + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//".bx" + else + write (licz3,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"_par"//licz3//".bx" + endif + else + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//"_slice_"//licz2//".bx" + else + write (licz3,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"par_"//licz3// & + "_slice_"//licz2//".bx" + endif + endif + open (ientout,file=bxname,status="unknown",& + form="unformatted",access="direct",recl=lenrec1) +#ifdef MPI + endif +#endif + do iparm=1,iparm + if (iparm.ne.iparmprint) exit + call restore_parm(iparm) + do ib=1,nT_h(iparm) +#ifdef DEBUG + write (iout,*) "iparm",iparm," ib",ib +#endif + temper=1.0d0/(beta_h(ib,iparm)*1.987D-3) +! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +! quotl=1.0d0 +! kfacl=1.0d0 +! do l=1,5 +! quotl1=quotl +! quotl=quotl*quot +! kfacl=kfacl*kfac +! fT(l)=kfacl/(kfacl-1.0d0+quotl) +! enddo +!el old rescale weights +! +! if (rescale_mode.eq.1) then +! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +#if defined(FUNCTH) + tt=1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=quot +#else + ft(6)=1.0d0 +#endif +! quotl=1.0d0 +! kfacl=1.0d0 +! do l=1,5 +! quotl1=quotl +! quotl=quotl*quot +! kfacl=kfacl*kfac +! fT(l)=kfacl/(kfacl-1.0d0+quotl) +! enddo +! else if (rescale_mode.eq.2) then +! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +!#if defined(FUNCTH) +! tt=1.0d0/(beta_h(ib,iparm)*1.987D-3) +! ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/3200.d0 +!#elif defined(FUNCT) +! ft(6)=quot +!#else +! ft(6)=1.0d0 +!#endif +! quotl=1.0d0 +! do l=1,5 +! quotl=quotl*quot +! fT(l)=1.12692801104297249644d0/ & +! dlog(dexp(quotl)+dexp(-quotl)) +! enddo +! write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft +! else if (rescale_mode.eq.0) then +! do l=1,5 +! fT(l)=0.0d0 +! enddo +! else +! write (iout,*) & +! "Error in MAKE_ENSEMBLE: Wrong RESCALE_MODE:",rescale_mode +! call flush(iout) +! return 1 +! endif +! el end old rescale weihgts + call rescale_weights(1.0d0/(beta_h(ib,iparm)*1.987D-3)) + +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif + evdw=enetb(1,i,iparm) +! evdw_t=enetb(21,i,iparm) + evdw_t=enetb(20,i,iparm) +#ifdef SCP14 +! evdw2_14=enetb(17,i,iparm) + evdw2_14=enetb(18,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eello_turn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) + + estr=enetb(17,i,iparm) +! estr=enetb(18,i,iparm) +! esccor=enetb(19,i,iparm) + esccor=enetb(21,i,iparm) +! edihcnstr=enetb(20,i,iparm) + edihcnstr=enetb(19,i,iparm) +!#ifdef SPLITELE +! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & +! +wvdwpp*evdw1 & +! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & +! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & +! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & +! +ft(2)*wturn3*eello_turn3 & +! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc & +! +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & +! +wbond*estr +!#else +! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & +! +ft(1)*welec*(ees+evdw1) & +! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & +! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & +! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & +! +ft(2)*wturn3*eello_turn3 & +! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr & +! +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & +! +wbond*estr +!#endif + +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees & + +wvdwpp*evdw1 & + +wang*ebe+wtor*etors+wscloc*escloc & + +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & + +wcorr6*ecorr6+wturn4*eello_turn4 & + +wturn3*eello_turn3 & + +wturn6*eello_turn6+wel_loc*eel_loc & + +edihcnstr+wtor_d*etors_d+wsccor*esccor & + +wbond*estr +#else + etot=wsc*evdw+wscp*evdw2 & + +welec*(ees+evdw1) & + +wang*ebe+wtor*etors+wscloc*escloc & + +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & + +wcorr6*ecorr6+wturn4*eello_turn4 & + +wturn3*eello_turn3 & + +wturn6*eello_turn6+wel_loc*eel_loc+edihcnstr & + +wtor_d*etors_d+wsccor*esccor & + +wbond*estr +#endif + +#ifdef MPI + Fdimless(i)= & + beta_h(ib,iparm)*etot-entfac(i) + potE(i,iparm)=etot +#ifdef DEBUG + write (iout,*) i,indstart(me)+i-1,ib,& + 1.0d0/(1.987d-3*beta_h(ib,iparm)),potE(i,iparm),& + -entfac(i),Fdimless(i) +#endif +#else + Fdimless(i)=beta_h(ib,iparm)*etot-entfac(i) + potE(i,iparm)=etot +#endif + enddo ! i +#ifdef MPI + do i=1,scount(me1) + Fdimless_(i)=Fdimless(i) + enddo + call MPI_Gatherv(Fdimless_(1),scount(me),& + MPI_REAL,Fdimless(1),& + scount_(0),idispl(0),MPI_REAL,Master,& + WHAM_COMM, IERROR) +#ifdef DEBUG + call MPI_Gatherv(potE(1,iparm),scount_(me),& + MPI_DOUBLE_PRECISION,potE(1,iparm),& + scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& + WHAM_COMM, IERROR) + call MPI_Gatherv(entfac(1),scount(me),& + MPI_DOUBLE_PRECISION,entfac(1),& + scount_(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& + WHAM_COMM, IERROR) +#endif + if (me.eq.Master) then +#ifdef DEBUG + write (iout,*) "The FDIMLESS array before sorting" + do i=1,ntot(islice) + write (iout,*) i,fdimless(i) + enddo +#endif +#endif + do i=1,ntot(islice) + iperm(i)=i + enddo + call mysort1(ntot(islice),Fdimless,iperm) +#ifdef DEBUG + write (iout,*) "The FDIMLESS array after sorting" + do i=1,ntot(islice) + write (iout,*) i,iperm(i),fdimless(i) + enddo +#endif + qfree=0.0d0 + do i=1,ntot(islice) + qfree=qfree+exp(-fdimless(i)+fdimless(1)) + enddo +! write (iout,*) "qfree",qfree + nlist=1 + sumprob=0.0 + do i=1,min0(ntot(islice),ensembles) + sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree +#ifdef DEBUG + write (iout,*) i,ib,beta_h(ib,iparm),& + 1.0d0/(1.987d-3*beta_h(ib,iparm)),iperm(i),& + potE(iperm(i),iparm),& + -entfac(iperm(i)),fdimless(i),sumprob +#endif + if (sumprob.gt.0.99d0) goto 122 + nlist=nlist+1 + enddo + 122 continue +#ifdef MPI + endif + call MPI_Bcast(nlist, 1, MPI_INTEGER, Master, WHAM_COMM,& + IERROR) + call MPI_Bcast(iperm,nlist,MPI_INTEGER,Master,WHAM_COMM,& + IERROR) + do i=1,nlist + ii=iperm(i) + iproc=0 + do while (ii.lt.indstart(iproc).or.ii.gt.indend(iproc)) + iproc=iproc+1 + enddo + if (iproc.ge.nprocs) then + write (iout,*) "Fatal error: processor out of range",iproc + call flush(iout) + if (bxfile) then + close (ientout) + else + close (ientout,status="delete") + endif + return 1 + endif + ik=ii-indstart(iproc)+1 + if (iproc.ne.Master) then + if (me.eq.iproc) then +#ifdef DEBUG + write (iout,*) "i",i," ii",ii," iproc",iproc," ik",ik,& + " energy",potE(ik,iparm) +#endif + call MPI_Send(potE(ik,iparm),1,MPI_DOUBLE_PRECISION,& + Master,i,WHAM_COMM,IERROR) + else if (me.eq.Master) then + call MPI_Recv(enepot(i),1,MPI_DOUBLE_PRECISION,iproc,i,& + WHAM_COMM,STATUS,IERROR) + endif + else if (me.eq.Master) then + enepot(i)=potE(ik,iparm) + endif + enddo +#else + do i=1,nlist + enepot(i)=potE(iperm(i),iparm) + enddo +#endif +#ifdef MPI + if (me.eq.Master) then +#endif + write(licz3,'(bz,i3.3)') iparm + write(licz2,'(bz,i2.2)') islice + if (temper.lt.100.0d0) then + write(ctemper,'(f3.0)') temper + else if (temper.lt.1000.0) then + write (ctemper,'(f4.0)') temper + else + write (ctemper,'(f5.0)') temper + endif + if (nparmset.eq.1) then + if (separate_parset) then + write(licz4,'(bz,i3.3)') myparm + pdbname=prefix(:ilen(prefix))//"_par"//licz4 + else + pdbname=prefix(:ilen(prefix)) + endif + else + pdbname=prefix(:ilen(prefix))//"_parm_"//licz3 + endif + if (nslice.eq.1) then + pdbname=pdbname(:ilen(pdbname))//"_T_"// & + ctemper(:ilen(ctemper))//"pdb" + else + pdbname=pdbname(:ilen(pdbname))//"_slice_"//licz2//"_T_"// & + ctemper(:ilen(ctemper))//"pdb" + endif + open(ipdb,file=pdbname) + do i=1,nlist + read (ientout,rec=iperm(i)) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,iscor + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + eini=fdimless(i) + call pdboutW(iperm(i),temper,eini,enepot(i),efree,rmsdev) + enddo +#ifdef MPI + endif +#endif + enddo ! ib + enddo ! iparm + if (bxfile) then + close(ientout) + else + close(ientout,status="delete") + endif + do i=0,nprocs + scount(i)=scount_(i) + enddo + return + end subroutine make_ensembles +!-------------------------------------------------------------------------- + subroutine mysort1(n, x, ipermut) +! implicit none + integer :: i,j,imax,ipm,n + real(kind=4) :: x(n) + integer :: ipermut(n) + real(kind=4) :: xtemp + do i=1,n + xtemp=x(i) + imax=i + do j=i+1,n + if (x(j).lt.xtemp) then + imax=j + xtemp=x(j) + endif + enddo + x(imax)=x(i) + x(i)=xtemp + ipm=ipermut(imax) + ipermut(imax)=ipermut(i) + ipermut(i)=ipm + enddo + return + end subroutine mysort1 +!-------------------------------------------------------------------------- + subroutine alloc_enecalc_arrays(iparm) + + use control_data + use geometry_data, only:maxlob + integer :: iparm +!--------------------------- +! COMMON.ENERGIES form wham_data +! common /energies/ + allocate(potE(MaxStr_Proc,iparm)) !(MaxStr_Proc,Max_Parm) + allocate(entfac(MaxStr_Proc)) !(MaxStr_Proc) + allocate(q(nQ+2,MaxStr_Proc)) !(MaxQ+2,MaxStr_Proc) + allocate(enetb(max_ene,MaxStr_Proc,iparm)) !(max_ene,MaxStr_Proc,Max_Parm) +! +! allocate ENECALC arrays +!--------------------------- +! COMMON.ALLPARM +! common /allparm/ + allocate(ww_all(max_eneW,iparm)) !(max_ene,max_parm) ! max_eneW + allocate(vbldp0_all(iparm),akp_all(nParmSet)) !(max_parm) + allocate(vbldsc0_all(maxbondterm,ntyp,iparm),& + aksc_all(maxbondterm,ntyp,iparm),& + abond0_all(maxbondterm,ntyp,iparm)) !(maxbondterm,ntyp,max_parm) + allocate(a0thet_all(-ntyp:ntyp,iparm)) !(-ntyp:ntyp,max_parm) + allocate(athet_all(2,-ntyp:ntyp,-1:1,-1:1,iparm),& + bthet_all(2,-ntyp:ntyp,-1:1,-1:1,iparm)) !(2,-ntyp:ntyp,-1:1,-1:1,max_parm) + allocate(polthet_all(0:3,-ntyp:ntyp,iparm)) !(0:3,-ntyp:ntyp,max_parm) + allocate(gthet_all(3,-ntyp:ntyp,iparm)) !(3,-ntyp:ntyp,max_parm) + allocate(theta0_all(-ntyp:ntyp,iparm),& + sig0_all(-ntyp:ntyp,iparm),sigc0_all(-ntyp:ntyp,nParmSet)) !(-ntyp:ntyp,max_parm) + allocate(aa0thet_all(-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) +!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) + allocate(aathet_all(maxtheterm,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) +!(maxtheterm,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) + allocate(bbthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) + allocate(ccthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) + allocate(ddthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) + allocate(eethet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) +!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, +! & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) + allocate(ffthet_all1(maxdouble,maxdouble,maxtheterm3,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,iparm)) + allocate(ggthet_all1(maxdouble,maxdouble,maxtheterm3,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,iparm)) + allocate(ffthet_all2(maxdouble,maxdouble,maxtheterm3,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,iparm)) + allocate(ggthet_all2(maxdouble,maxdouble,maxtheterm3,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,iparm)) +!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,& +!-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,max_parm) + allocate(dsc_all(ntyp1,iparm),dsc0_all(ntyp1,nParmSet)) !(ntyp1,max_parm) + allocate(bsc_all(maxlob,ntyp,iparm)) +!(maxlob,ntyp,max_parm) + allocate(censc_all(3,maxlob,-ntyp:ntyp,iparm)) !(3,maxlob,-ntyp:ntyp,max_parm) + allocate(gaussc_all(3,3,maxlob,-ntyp:ntyp,iparm)) !(3,3,maxlob,-ntyp:ntyp,max_parm) + allocate(sc_parmin_all(65,ntyp,iparm)) !(65,ntyp,max_parm) + allocate(v0_all(-maxtor:maxtor,-maxtor:maxtor,2,iparm)) +!(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(v1_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,iparm)) + allocate(v2_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,iparm)) +!(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(vlor1_all(maxlor,maxtor,maxtor,iparm)) + allocate(vlor2_all(maxlor,maxtor,maxtor,iparm)) + allocate(vlor3_all(maxlor,maxtor,maxtor,iparm)) !(maxlor,maxtor,maxtor,max_parm) + allocate(v1c_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,& + -maxtor:maxtor,2,iparm)) + allocate(v1s_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,& + -maxtor:maxtor,2,iparm)) +!(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(v2c_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,& + -maxtor:maxtor,-maxtor:maxtor,2,iparm)) +!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(v2s_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,& + -maxtor:maxtor,-maxtor:maxtor,2,iparm)) +!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(b1_all(2,-maxtor:maxtor,iparm)) + allocate(b2_all(2,-maxtor:maxtor,iparm)) !(2,-maxtor:maxtor,max_parm) + allocate(cc_all(2,2,-maxtor:maxtor,iparm)) + allocate(dd_all(2,2,-maxtor:maxtor,iparm)) + allocate(ee_all(2,2,-maxtor:maxtor,iparm)) !(2,2,-maxtor:maxtor,max_parm) + allocate(ctilde_all(2,2,-maxtor:maxtor,iparm)) + allocate(dtilde_all(2,2,-maxtor:maxtor,iparm)) !(2,2,-maxtor:maxtor,max_parm) + allocate(b1tilde_all(2,-maxtor:maxtor,iparm)) !(2,-maxtor:maxtor,max_parm) + allocate(app_all(2,2,iparm),bpp_all(2,2,nParmSet),& + ael6_all(2,2,iparm),ael3_all(2,2,nParmSet)) !(2,2,max_parm) + allocate(aad_all(ntyp,2,iparm),bad_all(ntyp,2,nParmSet)) !(ntyp,2,max_parm) + allocate(aa_all(ntyp,ntyp,iparm),bb_all(ntyp,ntyp,nParmSet),& + augm_all(ntyp,ntyp,iparm),eps_all(ntyp,ntyp,nParmSet),& + sigma_all(ntyp,ntyp,iparm),r0_all(ntyp,ntyp,nParmSet),& + chi_all(ntyp,ntyp,iparm)) !(ntyp,ntyp,max_parm) + allocate(chip_all(ntyp,iparm),alp_all(ntyp,nParmSet)) !(ntyp,max_parm) + allocate(ebr_all(iparm),d0cm_all(nParmSet),akcm_all(nParmSet),& + akth_all(iparm),akct_all(nParmSet),v1ss_all(nParmSet),& + v2ss_all(iparm),v3ss_all(nParmSet)) !(max_parm) + allocate(v1sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,iparm)) + allocate(v2sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,iparm)) +!(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm) + allocate(nlob_all(ntyp1,iparm)) !(ntyp1,max_parm) + allocate(nlor_all(-maxtor:maxtor,-maxtor:maxtor,2,iparm)) + allocate(nterm_all(-maxtor:maxtor,-maxtor:maxtor,2,iparm)) +!(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(ntermd1_all(-maxtor:maxtor,-maxtor:maxtor,& + -maxtor:maxtor,2,iparm)) + allocate(ntermd2_all(-maxtor:maxtor,-maxtor:maxtor,& + -maxtor:maxtor,2,iparm)) +!(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) + allocate(nbondterm_all(ntyp,iparm)) !(ntyp,max_parm) + allocate(ithetyp_all(-ntyp1:ntyp1,iparm)) !(-ntyp1:ntyp1,max_parm) + allocate(nthetyp_all(iparm),ntheterm_all(nParmSet),& + ntheterm2_all(iparm),ntheterm3_all(nParmSet),& + nsingle_all(iparm),& + ndouble_all(iparm),nntheterm_all(nParmSet)) !(max_parm) + allocate(nterm_sccor_all(-ntyp:ntyp,-ntyp:ntyp,iparm)) !(-ntyp:ntyp,-ntyp:ntyp,max_parm) +! + end subroutine alloc_enecalc_arrays +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + end module ene_calc diff --git a/source/wham/enecalc.f90 b/source/wham/enecalc.f90 deleted file mode 100644 index fd5f6ca..0000000 --- a/source/wham/enecalc.f90 +++ /dev/null @@ -1,1708 +0,0 @@ - module ene_calc -!----------------------------------------------------------------------------- - use io_units - use wham_data -! - use geometry_data, only:nres - use energy_data - use control_data, only:maxthetyp1 - use energy, only:etotal,enerprint,rescale_weights -#ifdef MPI - use MPI_data -! include "mpif.h" -! include "COMMON.MPI" -#endif - implicit none -!----------------------------------------------------------------------------- -! COMMON.ALLPARM -! common /allparm/ - real(kind=8),dimension(:,:),allocatable :: ww_all !(max_ene,max_parm) ! max_eneW - real(kind=8),dimension(:),allocatable :: vbldp0_all,akp_all !(max_parm) - real(kind=8),dimension(:,:,:),allocatable :: vbldsc0_all,& - aksc_all,abond0_all !(maxbondterm,ntyp,max_parm) - real(kind=8),dimension(:,:),allocatable :: a0thet_all !(-ntyp:ntyp,max_parm) - real(kind=8),dimension(:,:,:,:,:),allocatable :: athet_all,& - bthet_all !(2,-ntyp:ntyp,-1:1,-1:1,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: polthet_all !(0:3,-ntyp:ntyp,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: gthet_all !(3,-ntyp:ntyp,max_parm) - real(kind=8),dimension(:,:),allocatable :: theta0_all,& - sig0_all,sigc0_all !(-ntyp:ntyp,max_parm) - real(kind=8),dimension(:,:,:,:,:),allocatable :: aa0thet_all -!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) - real(kind=8),dimension(:,:,:,:,:,:),allocatable :: aathet_all -!(maxtheterm,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) - real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: bbthet_all,& - ccthet_all,ddthet_all,eethet_all !(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, -! & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) - real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: ffthet_all1,& - ggthet_all1,ffthet_all2,ggthet_all2 !(maxdouble,maxdouble,maxtheterm3, -! & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,max_parm) - real(kind=8),dimension(:,:),allocatable :: dsc_all,dsc0_all !(ntyp1,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: bsc_all !(maxlob,ntyp,max_parm) - real(kind=8),dimension(:,:,:,:),allocatable :: censc_all !(3,maxlob,-ntyp:ntyp,max_parm) - real(kind=8),dimension(:,:,:,:,:),allocatable :: gaussc_all !(3,3,maxlob,-ntyp:ntyp,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: sc_parmin_all !(65,ntyp,max_parm) - real(kind=8),dimension(:,:,:,:),allocatable :: v0_all -!(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - real(kind=8),dimension(:,:,:,:,:),allocatable :: v1_all,& - v2_all !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - real(kind=8),dimension(:,:,:,:),allocatable :: vlor1_all,& - vlor2_all,vlor3_all !(maxlor,maxtor,maxtor,max_parm) - real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: v1c_all,& - v1s_all !(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: v2c_all -!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - real(kind=8),dimension(:,:,:,:,:,:,:),allocatable :: v2s_all -!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: b1_all,b2_all !(2,-maxtor:maxtor,max_parm) - real(kind=8),dimension(:,:,:,:),allocatable :: cc_all,dd_all,& - ee_all !(2,2,-maxtor:maxtor,max_parm) - real(kind=8),dimension(:,:,:,:),allocatable :: ctilde_all,& - dtilde_all !(2,2,-maxtor:maxtor,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: b1tilde_all !(2,-maxtor:maxtor,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: app_all,bpp_all,& - ael6_all,ael3_all !(2,2,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: aad_all,& - bad_all !(ntyp,2,max_parm) - real(kind=8),dimension(:,:,:),allocatable :: aa_all,bb_all,& - augm_all,eps_all,sigma_all,r0_all,chi_all !(ntyp,ntyp,max_parm) - real(kind=8),dimension(:,:),allocatable :: chip_all,alp_all !(ntyp,max_parm) - real(kind=8),dimension(:),allocatable :: ebr_all,d0cm_all,& - akcm_all,akth_all,akct_all,v1ss_all,v2ss_all,v3ss_all !(max_parm) - real(kind=8),dimension(:,:,:,:,:),allocatable :: v1sccor_all,& - v2sccor_all !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm) - integer,dimension(:,:),allocatable :: nlob_all !(ntyp1,max_parm) - integer,dimension(:,:,:,:),allocatable :: nlor_all,& - nterm_all !(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - integer,dimension(:,:,:,:,:),allocatable :: ntermd1_all,& - ntermd2_all !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - integer,dimension(:,:),allocatable :: nbondterm_all !(ntyp,max_parm) - integer,dimension(:,:),allocatable :: ithetyp_all !(-ntyp1:ntyp1,max_parm) - integer,dimension(:),allocatable :: nthetyp_all,ntheterm_all,& - ntheterm2_all,ntheterm3_all,nsingle_all,ndouble_all,& - nntheterm_all !(max_parm) - integer,dimension(:,:,:),allocatable :: nterm_sccor_all !(-ntyp:ntyp,-ntyp:ntyp,max_parm) -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- - subroutine enecalc(islice,*) - - use names - use control_data, only:indpdb - use geometry_data, only:c,phi,theta,alph,omeg,deg2rad,anatemp,& - vbld,rad2deg,dc_norm,dc,vbld_inv - use io_base, only:gyrate!,briefout - use geometry, only:int_from_cart1 - use io_wham, only:pdboutW - use io_database, only:opentmp - use conform_compar, only:qwolynes,rmsnat -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -#ifdef MPI -! use MPI_data - include "mpif.h" -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.FFIELD" -! include "COMMON.ENEPS" -! include "COMMON.LOCAL" -! include "COMMON.WEIGHTS" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.CONTROL" -! include "COMMON.TORCNSTR" -! implicit none -#ifdef MPI - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -#endif - character(len=64) :: nazwa - character(len=80) :: bxname - character(len=3) :: liczba -!el real(kind=8) :: qwolynes -!el external qwolynes - integer :: errmsg_count,maxerrmsg_count=100 -!el real(kind=8) :: rmsnat,gyrate -!el external rmsnat,gyrate - real(kind=8) :: tole=1.0d-1 - integer i,itj,ii,iii,j,k,l,licz - integer ir,ib,ipar,iparm - integer iscor,islice - real(kind=4) :: csingle(3,nres*2) - real(kind=8) :: energ - real(kind=8) :: temp -!el integer ilen,iroof -!el external ilen,iroof - real(kind=8) :: energia(0:n_ene),rmsdev,efree,eini -!el real(kind=8) :: energia(0:max_ene),rmsdev,efree,eini - real(kind=8) :: fT(6),quot,quotl,kfacl,kfac=2.4d0,T0=3.0d2 - real(kind=8) :: tt - integer :: snk_p(MaxR,MaxT_h,nParmSet)!Max_parm) - logical :: lerr - character(len=64) :: bprotfile_temp - -! integer :: rec - integer,dimension(0:nprocs) :: scount_ -!el real(kind=8) :: rmsnat - - rescale_mode=rescale_modeW - - call opentmp(islice,ientout,bprotfile_temp) - iii=0 - ii=0 -!el -! iparm=1 - errmsg_count=0 - write (iout,*) "enecalc: nparmset ",nparmset -#ifdef MPI - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - snk_p(i,ib,iparm)=0 - enddo - enddo - enddo - do i=indstart(me1),indend(me1) -write(iout,*)"enecalc_ i indstart",i,indstart(me1),indend(me1) -#else - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - snk(i,ib,iparm)=0 - enddo - enddo - enddo - do i=1,ntot -write(iout,*)"enecalc_ i ntot",i,ntot -#endif - read(ientout,rec=i,err=101) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,(q(j,iii+1),j=1,nQ),iR,ib,ipar -!el debug -!write(iout,*)"co wczytuje" -! write(iout,*)((csingle(l,k),l=1,3),k=1,nres),& -! ((csingle(l,k+nres),l=1,3),k=nnt,nct),& -! nss,(ihpb(k),jhpb(k),k=1,nss),& -! eini,efree,rmsdev,(q(j,iii+1),j=1,nQ),iR,ib,ipar -!el -------- - -!write(iout,*)"ipar",ib,ipar,1.0d0/(beta_h(ib,ipar)*1.987D-3) - if (indpdb.gt.0) then - do k=1,nres - do l=1,3 - c(l,k)=csingle(l,k) - enddo - enddo - do k=nnt,nct - do l=1,3 - c(l,k+nres)=csingle(l,k+nres) - enddo - enddo - anatemp= 1.0d0/(beta_h(ib,ipar)*1.987D-3) - q(nQ+1,iii+1)=rmsnat(iii+1) - endif - q(nQ+2,iii+1)=gyrate(iii+1) -! write(iout,*)"wczyt",anatemp,q(nQ+2,iii+1) !el -! fT=T0*beta_h(ib,ipar)*1.987D-3 -! ft=2.0d0/(1.0d0+1.0d0/(T0*beta_h(ib,ipar)*1.987D-3)) -! EL start old rescale -! if (rescale_modeW.eq.1) then -! quot=1.0d0/(T0*beta_h(ib,ipar)*1.987D-3) -!#if defined(FUNCTH) -! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) -! ft(6)=(320.0+80.0*dtanh((tt-320.0)/80.0))/320.0 -!#elif defined(FUNCT) -! ft(6)=quot -!#else -! ft(6)=1.0d0 -!#endif -! quotl=1.0d0 -! kfacl=1.0d0 -! do l=1,5 -! quotl=quotl*quot -! kfacl=kfacl*kfac -! fT(l)=kfacl/(kfacl-1.0d0+quotl) -! enddo -! else if (rescale_modeW.eq.2) then -! quot=1.0d0/(T0*beta_h(ib,ipar)*1.987D-3) -!#if defined(FUNCTH) -! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) -! ft(6)=(320.0+80.0*dtanh((tt-320.0)/80.0))/320.0 -!#elif defined(FUNCT) -! ft(6)=quot -!#else -! ft(6)=1.0d0 -!#endif -! quotl=1.0d0 -! do l=1,5 -! quotl=quotl*quot -! fT(l)=1.12692801104297249644d0/ & -! dlog(dexp(quotl)+dexp(-quotl)) -! enddo -! else if (rescale_modeW.eq.0) then -! do l=1,5 -! fT(l)=1.0d0 -! enddo -! else -! write (iout,*) "Error in ECECALC: wrong RESCALE_MODE",& -! rescale_modeW -! call flush(iout) -! return 1 -! endif -!EL end old rescele -! write (iout,*) "T",1.0d0/(beta_h(ib,ipar)*1.987D-3)," T0",T0, -! & " kfac",kfac,"quot",quot," fT",fT -#ifdef DEBUG - write(iout,*)"weights" - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& - wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& - wtor_d,wsccor,wbond -#endif - - do j=1,2*nres - do k=1,3 - c(k,j)=csingle(k,j) - enddo - enddo - call int_from_cart1(.false.) - ii=ii+1 - -! call rescale_weights(1.0d0/(beta_h(ib,ipar)*1.987D-3)) - do iparm=1,nparmset -#ifdef DEBUG - write (iout,*) "before restore w=",1.0d0/(beta_h(ib,ipar)*1.987D-3) - write(iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& - wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& - wtor_d,wsccor,wbond -#endif - call restore_parm(iparm) - call rescale_weights(1.0d0/(beta_h(ib,ipar)*1.987D-3)) -#ifdef DEBUG - write (iout,*) "before etot w=",1.0d0/(beta_h(ib,ipar)*1.987D-3) - write(iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& - wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& - wtor_d,wsccor,wbond -#endif -! call etotal(energia(0),fT) - call etotal(energia(0)) -!write(iout,*)"check c and dc after etotal",1.0d0/(0.001987*beta_h(ib,ipar)) -!do k=1,2*nres+2 -!write(iout,*)k,"c=",(c(l,k),l=1,3) -!write(iout,*)k,"dc=",(dc(l,k),l=1,3) -!write(iout,*)k,"dc_norm=",(dc_norm(l,k),l=1,3) -!enddo -!do k=1,nres*2 -!write(iout,*)k,"vbld=",vbld(k) -!write(iout,*)k,"vbld_inv=",vbld_inv(k) -!enddo - -!write(iout,*)"energia",(energia(j),j=0,n_ene) -!write(iout,*)"enerprint tuz po call etotal" - call enerprint(energia(0)) -#ifdef DEBUG - write (iout,*) "Conformation",i - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) -! call enerprint(energia(0),fT) - call enerprint(energia(0)) - write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) - write (iout,*) "ftors",ftors -!el call briefout(i,energia(0)) - temp=1.0d0/(beta_h(ib,ipar)*1.987D-3) - write (iout,*) "temp", temp - call pdboutW(i,temp,energia(0),energia(0),0.0d0,0.0d0) -#endif - if (energia(0).ge.1.0d20) then - write (iout,*) "NaNs detected in some of the energy",& - " components for conformation",ii+1 - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" -! call intout -! call pdboutW(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,*) "The components of the energy are:" -! call enerprint(energia(0),fT) - call enerprint(energia(0)) - write (iout,*) & - "This conformation WILL NOT be added to the database." - call flush(iout) - goto 121 - else -#ifdef DEBUG - if (ipar.eq.iparm) write (iout,*) i,iparm,& - 1.0d0/(beta_h(ib,ipar)*1.987D-3),eini,energia(0) -#endif - if (ipar.eq.iparm .and. einicheck.gt.0 .and. & - dabs(eini-energia(0)).gt.tole) then - if (errmsg_count.le.maxerrmsg_count) then - write (iout,'(2a,2e15.5,a,2i8,a,f8.1)') & - "Warning: energy differs remarkably from ",& - " the value read in: ",energia(0),eini," point",& - iii+1,indstart(me1)+iii," T",& - 1.0d0/(1.987D-3*beta_h(ib,ipar)) -! call intout - call pdboutW(indstart(me1)+iii,& - 1.0d0/(1.987D-3*beta_h(ib,ipar)),& - energia(0),eini,0.0d0,0.0d0) - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" -! call intout -! call pdboutW(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - call enerprint(energia(0)) -! call enerprint(energia(0),fT) - errmsg_count=errmsg_count+1 - if (errmsg_count.gt.maxerrmsg_count) & - write (iout,*) "Too many warning messages" - if (einicheck.gt.1) then - write (iout,*) "Calculation stopped." - call flush(iout) -#ifdef MPI - call MPI_Abort(WHAM_COMM,IERROR,ERRCODE) -#endif - call flush(iout) - return 1 - endif - endif - endif - potE(iii+1,iparm)=energia(0) - do k=1,21 - enetb(k,iii+1,iparm)=energia(k) - enddo -! write (iout,'(2i5,21f8.2)') "debug",k,iii+1,(enetb(k,iii+1,iparm),k=1,21) -! write (iout,*) "debug",k,iii+1,(enetb(k,iii+1,iparm),k=1,21) -#ifdef DEBUG - write (iout,'(2i5,f10.1,3e15.5)') i,iii,& - 1.0d0/(beta_h(ib,ipar)*1.987D-3),energia(0),eini,efree -! call enerprint(energia(0),fT) -#endif -#ifdef DEBUG - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) - write (iout,'(8f10.5)') (q(k,iii+1),k=1,nQ) - write (iout,'(f10.5,i10)') rmsdev,iscor -! call enerprint(energia(0),fT) - call enerprint(energia(0)) - call pdboutW(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) -#endif - endif - - enddo ! iparm - - iii=iii+1 - if (q(1,iii).le.0.0d0 .and. indpdb.gt.0) q(1,iii)=qwolynes(0,0) - write (ientout,rec=iii) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - potE(iii,ipar),efree,rmsdev,(q(k,iii),k=1,nQ),iR,ib,ipar -! write (iout,'(2i5,2e15.5)') ii,iii,potE(iii,ipar),efree -#ifdef MPI - if (separate_parset) then - snk_p(iR,ib,1)=snk_p(iR,ib,1)+1 - else - snk_p(iR,ib,ipar)=snk_p(iR,ib,ipar)+1 - endif -! write (iout,*) "iii",iii," iR",iR," ib",ib," ipar",ipar, -! & " snk",snk_p(iR,ib,ipar) -#else - snk(iR,ib,ipar,islice)=snk(iR,ib,ipar,islice)+1 -#endif - 121 continue - enddo -#ifdef MPI - scount(me)=iii - write (iout,*) "Me",me," scount",scount(me) - call flush(iout) -! Master gathers updated numbers of conformations written by all procs. - call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount_(0), 1, & - MPI_INTEGER, WHAM_COMM, IERROR) - indstart(0)=1 - indend(0)=scount_(0) - do i=1, Nprocs-1 - indstart(i)=indend(i-1)+1 - indend(i)=indstart(i)+scount_(i)-1 - enddo - write (iout,*) - write (iout,*) "Revised conformation counts" - do i=0,nprocs1-1 - write (iout,'(a,i5,a,i7,a,i7,a,i7)') & - "Processor",i," indstart",indstart(i),& - " indend",indend(i)," count",scount_(i) - enddo - call flush(iout) - call MPI_AllReduce(snk_p(1,1,1),snk(1,1,1,islice),& - MaxR*MaxT_h*nParmSet,& - MPI_INTEGER,MPI_SUM,WHAM_COMM,IERROR) -#endif - stot(islice)=0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - stot(islice)=stot(islice)+snk(i,ib,iparm,islice) - enddo - enddo - enddo - write (iout,*) "Revised SNK" - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - write (iout,'("Param",i3," Temp",f6.1,3x,32i8)') & - iparm,1.0d0/(1.987D-3*beta_h(ib,iparm)),& - (snk(i,ib,iparm,islice),i=1,nR(ib,iparm)) - write (iout,*) "snk_p",(snk_p(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo - write (iout,'("Total",i10)') stot(islice) - call flush(iout) - do i=0,nprocs - scount(i)=scount_(i) - enddo - return - 101 write (iout,*) "Error in scratchfile." - call flush(iout) -!el#undef DEBUG - return 1 - end subroutine enecalc -!------------------------------------------------------------------------------ - logical function conf_check(ii,iprint) - - use geometry_data, only:c,phi,theta,alph,omeg,deg2rad,rad2deg,vbld - use geometry, only:int_from_cart1 -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -#ifdef MPI -! use MPI_data - include "mpif.h" -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.FFIELD" -! include "COMMON.ENEPS" -! include "COMMON.LOCAL" -! include "COMMON.WEIGHTS" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.CONTROL" -! include "COMMON.TORCNSTR" -! implicit none -#ifdef MPI - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -#endif - integer :: j,k,l,ii,itj,iprint - if (.not.check_conf) then - conf_check=.true. - return - endif - call int_from_cart1(.false.) - do j=nnt+1,nct - if (itype(j-1).ne.ntyp1 .and. itype(j).ne.ntyp1 .and. & - (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0)) then - if (iprint.gt.0) & - write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),& - " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) & - "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=nnt,nct - itj=itype(j) - if (itype(j).ne.10 .and.itype(j).ne.ntyp1 .and. & - (vbld(nres+j)-dsc(iabs(itj))).gt.2.0d0) then - if (iprint.gt.0) & - write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j),& - " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) & - "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=3,nres - if (theta(j).le.0.0d0) then - if (iprint.gt.0) & - write (iout,*) "Zero theta angle(s) in conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) & - "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad - enddo - conf_check=.true. -! write (iout,*) "conf_check passed",ii - return - end function conf_check -!----------------------------------------------------------------------------- -! store_parm.F -!----------------------------------------------------------------------------- - subroutine store_parm(iparm) -! -! Store parameters of set IPARM -! valence angles and the side chains and energy parameters. -! -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' -! include 'COMMON.SBRIDGE' -! include 'COMMON.SCROT' -! include 'COMMON.SCCOR' -! include 'COMMON.ALLPARM' - integer :: i,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii - - call alloc_enecalc_arrays(iparm) -!el allocate(ww_all(n_ene,iparm)) -! Store weights - ww_all(1,iparm)=wsc - ww_all(2,iparm)=wscp - ww_all(3,iparm)=welec - ww_all(4,iparm)=wcorr - ww_all(5,iparm)=wcorr5 - ww_all(6,iparm)=wcorr6 - ww_all(7,iparm)=wel_loc - ww_all(8,iparm)=wturn3 - ww_all(9,iparm)=wturn4 - ww_all(10,iparm)=wturn6 - ww_all(11,iparm)=wang - ww_all(12,iparm)=wscloc - ww_all(13,iparm)=wtor - ww_all(14,iparm)=wtor_d - ww_all(15,iparm)=wstrain - ww_all(16,iparm)=wvdwpp - ww_all(17,iparm)=wbond - ww_all(19,iparm)=wsccor -! Store bond parameters - vbldp0_all(iparm)=vbldp0 - akp_all(iparm)=akp - do i=1,ntyp - nbondterm_all(i,iparm)=nbondterm(i) - do j=1,nbondterm(i) - vbldsc0_all(j,i,iparm)=vbldsc0(j,i) - aksc_all(j,i,iparm)=aksc(j,i) - abond0_all(j,i,iparm)=abond0(j,i) - enddo - enddo -! Store bond angle parameters -#ifdef CRYST_THETA - do i=-ntyp,ntyp - a0thet_all(i,iparm)=a0thet(i) - do ichir1=-1,1 - do ichir2=-1,1 - do j=1,2 - athet_all(j,i,ichir1,ichir2,iparm)=athet(j,i,ichir1,ichir2) - bthet_all(j,i,ichir1,ichir2,iparm)=bthet(j,i,ichir1,ichir2) - enddo - enddo - enddo - do j=0,3 - polthet_all(j,i,iparm)=polthet(j,i) - enddo - do j=1,3 - gthet_all(j,i,iparm)=gthet(j,i) - enddo - theta0_all(i,iparm)=theta0(i) - sig0_all(i,iparm)=sig0(i) - sigc0_all(i,iparm)=sigc0(i) - enddo -#else - nthetyp_all(iparm)=nthetyp - ntheterm_all(iparm)=ntheterm - ntheterm2_all(iparm)=ntheterm2 - ntheterm3_all(iparm)=ntheterm3 - nsingle_all(iparm)=nsingle - ndouble_all(iparm)=ndouble - nntheterm_all(iparm)=nntheterm - do i=-ntyp,ntyp - ithetyp_all(i,iparm)=ithetyp(i) - enddo - do iblock=1,2 - do i=-maxthetyp1,maxthetyp1 - do j=-maxthetyp1,maxthetyp1 - do k=-maxthetyp1,maxthetyp1 - aa0thet_all(i,j,k,iblock,iparm)=aa0thet(i,j,k,iblock) - do l=1,ntheterm - aathet_all(l,i,j,k,iblock,iparm)=aathet(l,i,j,k,iblock) - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet_all(m,l,i,j,k,iblock,iparm)= & - bbthet(m,l,i,j,k,iblock) - ccthet_all(m,l,i,j,k,iblock,iparm)= & - ccthet(m,l,i,j,k,iblock) - ddthet_all(m,l,i,j,k,iblock,iparm)= & - ddthet(m,l,i,j,k,iblock) - eethet_all(m,l,i,j,k,iblock,iparm)= & - eethet(m,l,i,j,k,iblock) - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - if (iblock.eq.1) then - ffthet_all1(mm,m,l,i,j,k,iparm)=& - ffthet(mm,m,l,i,j,k,iblock) - ggthet_all1(mm,m,l,i,j,k,iparm)=& - ggthet(mm,m,l,i,j,k,iblock) - else - ffthet_all2(mm,m,l,i,j,k,iparm)=& - ffthet(mm,m,l,i,j,k,iblock) - ggthet_all2(mm,m,l,i,j,k,iparm)=& - ggthet(mm,m,l,i,j,k,iblock) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo -#endif -#ifdef CRYST_SC -! Store the sidechain rotamer parameters - do i=-ntyp,ntyp - iii=iabs(i) -!! write (iout,*) i,"storeparm1" - if (i.eq.0) cycle - nlob_all(iii,iparm)=nlob(iii) - do j=1,nlob(iii) - bsc_all(j,iii,iparm)=bsc(j,iii) - do k=1,3 - censc_all(k,j,i,iparm)=censc(k,j,i) - enddo - do k=1,3 - do l=1,3 - gaussc_all(l,k,j,i,iparm)=gaussc(l,k,j,i) - enddo - enddo - enddo - enddo -#else - do i=1,ntyp - do j=1,65 - sc_parmin_all(j,i,iparm)=sc_parmin(j,i) - enddo - enddo -#endif -! Store the torsional parameters - do iblock=1,2 - do i=-ntortyp+1,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - v0_all(i,j,iblock,iparm)=v0(i,j,iblock) - nterm_all(i,j,iblock,iparm)=nterm(i,j,iblock) - nlor_all(i,j,iblock,iparm)=nlor(i,j,iblock) - do k=1,nterm(i,j,iblock) - v1_all(k,i,j,iblock,iparm)=v1(k,i,j,iblock) - v2_all(k,i,j,iblock,iparm)=v2(k,i,j,iblock) - enddo - do k=1,nlor(i,j,iblock) - vlor1_all(k,i,j,iparm)=vlor1(k,i,j) - vlor2_all(k,i,j,iparm)=vlor2(k,i,j) - vlor3_all(k,i,j,iparm)=vlor3(k,i,j) - enddo - enddo - enddo - enddo -! Store the double torsional parameters - do iblock=1,2 - do i=-ntortyp+1,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - do k=-ntortyp+1,ntortyp-1 - ntermd1_all(i,j,k,iblock,iparm)=ntermd_1(i,j,k,iblock) - ntermd2_all(i,j,k,iblock,iparm)=ntermd_2(i,j,k,iblock) - do l=1,ntermd_1(i,j,k,iblock) - v1c_all(1,l,i,j,k,iblock,iparm)=v1c(1,l,i,j,k,iblock) - v1c_all(2,l,i,j,k,iblock,iparm)=v1c(2,l,i,j,k,iblock) - v2c_all(1,l,i,j,k,iblock,iparm)=v2c(1,l,i,j,k,iblock) - v2c_all(2,l,i,j,k,iblock,iparm)=v2c(2,l,i,j,k,iblock) - enddo - do l=1,ntermd_2(i,j,k,iblock) - do m=1,ntermd_2(i,j,k,iblock) - v2s_all(l,m,i,j,k,iblock,iparm)=v2s(l,m,i,j,k,iblock) - enddo - enddo - enddo - enddo - enddo - enddo -! Store parameters of the cumulants - do i=-nloctyp,nloctyp - do j=1,2 - b1_all(j,i,iparm)=b1(j,i) - b1tilde_all(j,i,iparm)=b1tilde(j,i) - b2_all(j,i,iparm)=b2(j,i) - enddo - do j=1,2 - do k=1,2 - cc_all(k,j,i,iparm)=cc(k,j,i) - ctilde_all(k,j,i,iparm)=ctilde(k,j,i) - dd_all(k,j,i,iparm)=dd(k,j,i) - dtilde_all(k,j,i,iparm)=dtilde(k,j,i) - ee_all(k,j,i,iparm)=ee(k,j,i) - enddo - enddo - enddo -! Store the parameters of electrostatic interactions - do i=1,2 - do j=1,2 - app_all(j,i,iparm)=app(j,i) - bpp_all(j,i,iparm)=bpp(j,i) - ael6_all(j,i,iparm)=ael6(j,i) - ael3_all(j,i,iparm)=ael3(j,i) - enddo - enddo -! Store sidechain parameters - do i=1,ntyp - do j=1,ntyp - aa_all(j,i,iparm)=aa(j,i) - bb_all(j,i,iparm)=bb(j,i) - r0_all(j,i,iparm)=r0(j,i) - sigma_all(j,i,iparm)=sigma(j,i) - chi_all(j,i,iparm)=chi(j,i) - augm_all(j,i,iparm)=augm(j,i) - eps_all(j,i,iparm)=eps(j,i) - enddo - enddo - do i=1,ntyp - chip_all(i,iparm)=chip(i) - alp_all(i,iparm)=alp(i) - enddo -! Store the SCp parameters - do i=1,ntyp - do j=1,2 - aad_all(i,j,iparm)=aad(i,j) - bad_all(i,j,iparm)=bad(i,j) - enddo - enddo -! Store disulfide-bond parameters - ebr_all(iparm)=ebr - d0cm_all(iparm)=d0cm - akcm_all(iparm)=akcm - akth_all(iparm)=akth - akct_all(iparm)=akct - v1ss_all(iparm)=v1ss - v2ss_all(iparm)=v2ss - v3ss_all(iparm)=v3ss -! Store SC-backbone correlation parameters - do i=-nsccortyp,nsccortyp - do j=-nsccortyp,nsccortyp - - nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i) -! do i=1,20 -! do j=1,20 - do l=1,3 - do k=1,nterm_sccor(j,i) - v1sccor_all(k,l,j,i,iparm)=v1sccor(k,l,j,i) - v2sccor_all(k,l,j,i,iparm)=v2sccor(k,l,j,i) - enddo - enddo - enddo - enddo -write(iout,*)"end of store_parm" - return - end subroutine store_parm -!-------------------------------------------------------------------------- - subroutine restore_parm(iparm) -! -! Store parameters of set IPARM -! valence angles and the side chains and energy parameters. -! -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' -! include 'COMMON.SBRIDGE' -! include 'COMMON.SCROT' -! include 'COMMON.SCCOR' -! include 'COMMON.ALLPARM' - integer :: i,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii - -! Restore weights - wsc=ww_all(1,iparm) - wscp=ww_all(2,iparm) - welec=ww_all(3,iparm) - wcorr=ww_all(4,iparm) - wcorr5=ww_all(5,iparm) - wcorr6=ww_all(6,iparm) - wel_loc=ww_all(7,iparm) - wturn3=ww_all(8,iparm) - wturn4=ww_all(9,iparm) - wturn6=ww_all(10,iparm) - wang=ww_all(11,iparm) - wscloc=ww_all(12,iparm) - wtor=ww_all(13,iparm) - wtor_d=ww_all(14,iparm) - wstrain=ww_all(15,iparm) - wvdwpp=ww_all(16,iparm) - wbond=ww_all(17,iparm) - wsccor=ww_all(19,iparm) -! Restore bond parameters - vbldp0=vbldp0_all(iparm) - akp=akp_all(iparm) - do i=1,ntyp - nbondterm(i)=nbondterm_all(i,iparm) - do j=1,nbondterm(i) - vbldsc0(j,i)=vbldsc0_all(j,i,iparm) - aksc(j,i)=aksc_all(j,i,iparm) - abond0(j,i)=abond0_all(j,i,iparm) - enddo - enddo -! Restore bond angle parameters -#ifdef CRYST_THETA - do i=-ntyp,ntyp - a0thet(i)=a0thet_all(i,iparm) - do ichir1=-1,1 - do ichir2=-1,1 - do j=1,2 - athet(j,i,ichir1,ichir2)=athet_all(j,i,ichir1,ichir2,iparm) - bthet(j,i,ichir1,ichir2)=bthet_all(j,i,ichir1,ichir2,iparm) - enddo - enddo - enddo - do j=0,3 - polthet(j,i)=polthet_all(j,i,iparm) - enddo - do j=1,3 - gthet(j,i)=gthet_all(j,i,iparm) - enddo - theta0(i)=theta0_all(i,iparm) - sig0(i)=sig0_all(i,iparm) - sigc0(i)=sigc0_all(i,iparm) - enddo -#else - nthetyp=nthetyp_all(iparm) - ntheterm=ntheterm_all(iparm) - ntheterm2=ntheterm2_all(iparm) - ntheterm3=ntheterm3_all(iparm) - nsingle=nsingle_all(iparm) - ndouble=ndouble_all(iparm) - nntheterm=nntheterm_all(iparm) - do i=-ntyp,ntyp - ithetyp(i)=ithetyp_all(i,iparm) - enddo - do iblock=1,2 - do i=-maxthetyp1,maxthetyp1 - do j=-maxthetyp1,maxthetyp1 - do k=-maxthetyp1,maxthetyp1 - aa0thet(i,j,k,iblock)=aa0thet_all(i,j,k,iblock,iparm) - do l=1,ntheterm - aathet(l,i,j,k,iblock)=aathet_all(l,i,j,k,iblock,iparm) - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k,iblock)= & - bbthet_all(m,l,i,j,k,iblock,iparm) - ccthet(m,l,i,j,k,iblock)= & - ccthet_all(m,l,i,j,k,iblock,iparm) - ddthet(m,l,i,j,k,iblock)= & - ddthet_all(m,l,i,j,k,iblock,iparm) - eethet(m,l,i,j,k,iblock)= & - eethet_all(m,l,i,j,k,iblock,iparm) - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - if (iblock.eq.1) then - ffthet(mm,m,l,i,j,k,iblock)= & - ffthet_all1(mm,m,l,i,j,k,iparm) - ggthet(mm,m,l,i,j,k,iblock)= & - ggthet_all1(mm,m,l,i,j,k,iparm) - else - ffthet(mm,m,l,i,j,k,iblock)= & - ffthet_all2(mm,m,l,i,j,k,iparm) - ggthet(mm,m,l,i,j,k,iblock)= & - ggthet_all2(mm,m,l,i,j,k,iparm) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo -#endif -! Restore the sidechain rotamer parameters -#ifdef CRYST_SC - do i=-ntyp,ntyp - if (i.eq.0) cycle - iii=iabs(i) - nlob(iii)=nlob_all(iii,iparm) - do j=1,nlob(iii) - bsc(j,iii)=bsc_all(j,iii,iparm) - do k=1,3 - censc(k,j,i)=censc_all(k,j,i,iparm) - enddo - do k=1,3 - do l=1,3 - gaussc(l,k,j,i)=gaussc_all(l,k,j,i,iparm) - enddo - enddo - enddo - enddo -#else - do i=1,ntyp - do j=1,65 - sc_parmin(j,i)=sc_parmin_all(j,i,iparm) - enddo - enddo -#endif -! Restore the torsional parameters - do iblock=1,2 - do i=-ntortyp+1,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - v0(i,j,iblock)=v0_all(i,j,iblock,iparm) - nterm(i,j,iblock)=nterm_all(i,j,iblock,iparm) - nlor(i,j,iblock)=nlor_all(i,j,iblock,iparm) - do k=1,nterm(i,j,iblock) - v1(k,i,j,iblock)=v1_all(k,i,j,iblock,iparm) - v2(k,i,j,iblock)=v2_all(k,i,j,iblock,iparm) - enddo - do k=1,nlor(i,j,iblock) - vlor1(k,i,j)=vlor1_all(k,i,j,iparm) - vlor2(k,i,j)=vlor2_all(k,i,j,iparm) - vlor3(k,i,j)=vlor3_all(k,i,j,iparm) - enddo - enddo - enddo - enddo -! Restore the double torsional parameters - do iblock=1,2 - do i=-ntortyp+1,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - do k=-ntortyp+1,ntortyp-1 - ntermd_1(i,j,k,iblock)=ntermd1_all(i,j,k,iblock,iparm) - ntermd_2(i,j,k,iblock)=ntermd2_all(i,j,k,iblock,iparm) - do l=1,ntermd_1(i,j,k,iblock) - v1c(1,l,i,j,k,iblock)=v1c_all(1,l,i,j,k,iblock,iparm) - v1c(2,l,i,j,k,iblock)=v1c_all(2,l,i,j,k,iblock,iparm) - v2c(1,l,i,j,k,iblock)=v2c_all(1,l,i,j,k,iblock,iparm) - v2c(2,l,i,j,k,iblock)=v2c_all(2,l,i,j,k,iblock,iparm) - enddo - do l=1,ntermd_2(i,j,k,iblock) - do m=1,ntermd_2(i,j,k,iblock) - v2s(l,m,i,j,k,iblock)=v2s_all(l,m,i,j,k,iblock,iparm) - enddo - enddo - enddo - enddo - enddo - enddo -! Restore parameters of the cumulants - do i=-nloctyp,nloctyp - do j=1,2 - b1(j,i)=b1_all(j,i,iparm) - b1tilde(j,i)=b1tilde_all(j,i,iparm) - b2(j,i)=b2_all(j,i,iparm) - enddo - do j=1,2 - do k=1,2 - cc(k,j,i)=cc_all(k,j,i,iparm) - ctilde(k,j,i)=ctilde_all(k,j,i,iparm) - dd(k,j,i)=dd_all(k,j,i,iparm) - dtilde(k,j,i)=dtilde_all(k,j,i,iparm) - ee(k,j,i)=ee_all(k,j,i,iparm) - enddo - enddo - enddo -! Restore the parameters of electrostatic interactions - do i=1,2 - do j=1,2 - app(j,i)=app_all(j,i,iparm) - bpp(j,i)=bpp_all(j,i,iparm) - ael6(j,i)=ael6_all(j,i,iparm) - ael3(j,i)=ael3_all(j,i,iparm) - enddo - enddo -! Restore sidechain parameters - do i=1,ntyp - do j=1,ntyp - aa(j,i)=aa_all(j,i,iparm) - bb(j,i)=bb_all(j,i,iparm) - r0(j,i)=r0_all(j,i,iparm) - sigma(j,i)=sigma_all(j,i,iparm) - chi(j,i)=chi_all(j,i,iparm) - augm(j,i)=augm_all(j,i,iparm) - eps(j,i)=eps_all(j,i,iparm) - enddo - enddo - do i=1,ntyp - chip(i)=chip_all(i,iparm) - alp(i)=alp_all(i,iparm) - enddo -! Restore the SCp parameters - do i=1,ntyp - do j=1,2 - aad(i,j)=aad_all(i,j,iparm) - bad(i,j)=bad_all(i,j,iparm) - enddo - enddo -! Restore disulfide-bond parameters - ebr=ebr_all(iparm) - d0cm=d0cm_all(iparm) - akcm=akcm_all(iparm) - akth=akth_all(iparm) - akct=akct_all(iparm) - v1ss=v1ss_all(iparm) - v2ss=v2ss_all(iparm) - v3ss=v3ss_all(iparm) -! Restore SC-backbone correlation parameters - do i=-nsccortyp,nsccortyp - do j=-nsccortyp,nsccortyp - - nterm_sccor(j,i)=nterm_sccor_all(j,i,iparm) - do l=1,3 - do k=1,nterm_sccor(j,i) - v1sccor(k,l,j,i)=v1sccor_all(k,l,j,i,iparm) - v2sccor(k,l,j,i)=v2sccor_all(k,l,j,i,iparm) - enddo - enddo - enddo - enddo - return - end subroutine restore_parm -!-------------------------------------------------------------------------- -! make_ensemble1.F -!-------------------------------------------------------------------------- - subroutine make_ensembles(islice,*) -! construct the conformational ensembles at REMD temperatures - use geometry_data, only:c - use io_base, only:ilen - use io_wham, only:pdboutW -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -#ifdef MPI - include "mpif.h" -! include "COMMON.MPI" - integer :: ierror,errcode,status(MPI_STATUS_SIZE) -#endif -! include "COMMON.IOUNITS" -! include "COMMON.CONTROL" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.FFIELD" -! include "COMMON.INTERACT" -! include "COMMON.SBRIDGE" -! include "COMMON.CHAIN" -! include "COMMON.PROTFILES" -! include "COMMON.PROT" - real(kind=4) :: csingle(3,nres*2) - real(kind=8),dimension(6) :: fT,fTprim,fTbis - real(kind=8) :: quot,quotl1,quotl,kfacl,& - eprim,ebis,temper,kfac=2.4d0,T0=300.0d0 - real(kind=8) :: etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors,& - escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,& - eello_turn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt - integer :: i,ii,ik,iproc,iscor,j,k,l,ib,iparm,iprot,nlist - real(kind=8) :: qfree,sumprob,eini,efree,rmsdev - character(len=80) :: bxname - character(len=2) :: licz1,licz2 - character(len=3) :: licz3,licz4 - character(len=5) :: ctemper -!el integer ilen -!el external ilen - real(kind=4) :: Fdimless(MaxStr),Fdimless_(MaxStr) - real(kind=8) :: enepot(MaxStr) - integer :: iperm(MaxStr) - integer :: islice - integer,dimension(0:nprocs) :: scount_ - -#ifdef MPI - if (me.eq.Master) then -#endif - write (licz2,'(bz,i2.2)') islice - if (nslice.eq.1) then - if (.not.separate_parset) then - bxname = prefix(:ilen(prefix))//".bx" - else - write (licz3,'(bz,i3.3)') myparm - bxname = prefix(:ilen(prefix))//"_par"//licz3//".bx" - endif - else - if (.not.separate_parset) then - bxname = prefix(:ilen(prefix))//"_slice_"//licz2//".bx" - else - write (licz3,'(bz,i3.3)') myparm - bxname = prefix(:ilen(prefix))//"par_"//licz3// & - "_slice_"//licz2//".bx" - endif - endif - open (ientout,file=bxname,status="unknown",& - form="unformatted",access="direct",recl=lenrec1) -#ifdef MPI - endif -#endif - do iparm=1,iparm - if (iparm.ne.iparmprint) exit - call restore_parm(iparm) - do ib=1,nT_h(iparm) -#ifdef DEBUG - write (iout,*) "iparm",iparm," ib",ib -#endif - temper=1.0d0/(beta_h(ib,iparm)*1.987D-3) -! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) -! quotl=1.0d0 -! kfacl=1.0d0 -! do l=1,5 -! quotl1=quotl -! quotl=quotl*quot -! kfacl=kfacl*kfac -! fT(l)=kfacl/(kfacl-1.0d0+quotl) -! enddo -!el old rescale weights -! -! if (rescale_mode.eq.1) then -! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) -#if defined(FUNCTH) - tt=1.0d0/(beta_h(ib,iparm)*1.987D-3) - ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 -#elif defined(FUNCT) - ft(6)=quot -#else - ft(6)=1.0d0 -#endif -! quotl=1.0d0 -! kfacl=1.0d0 -! do l=1,5 -! quotl1=quotl -! quotl=quotl*quot -! kfacl=kfacl*kfac -! fT(l)=kfacl/(kfacl-1.0d0+quotl) -! enddo -! else if (rescale_mode.eq.2) then -! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) -!#if defined(FUNCTH) -! tt=1.0d0/(beta_h(ib,iparm)*1.987D-3) -! ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/3200.d0 -!#elif defined(FUNCT) -! ft(6)=quot -!#else -! ft(6)=1.0d0 -!#endif -! quotl=1.0d0 -! do l=1,5 -! quotl=quotl*quot -! fT(l)=1.12692801104297249644d0/ & -! dlog(dexp(quotl)+dexp(-quotl)) -! enddo -! write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft -! else if (rescale_mode.eq.0) then -! do l=1,5 -! fT(l)=0.0d0 -! enddo -! else -! write (iout,*) & -! "Error in MAKE_ENSEMBLE: Wrong RESCALE_MODE:",rescale_mode -! call flush(iout) -! return 1 -! endif -! el end old rescale weihgts - call rescale_weights(1.0d0/(beta_h(ib,iparm)*1.987D-3)) - -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif - evdw=enetb(1,i,iparm) -! evdw_t=enetb(21,i,iparm) - evdw_t=enetb(20,i,iparm) -#ifdef SCP14 -! evdw2_14=enetb(17,i,iparm) - evdw2_14=enetb(18,i,iparm) - evdw2=enetb(2,i,iparm)+evdw2_14 -#else - evdw2=enetb(2,i,iparm) - evdw2_14=0.0d0 -#endif -#ifdef SPLITELE - ees=enetb(3,i,iparm) - evdw1=enetb(16,i,iparm) -#else - ees=enetb(3,i,iparm) - evdw1=0.0d0 -#endif - ecorr=enetb(4,i,iparm) - ecorr5=enetb(5,i,iparm) - ecorr6=enetb(6,i,iparm) - eel_loc=enetb(7,i,iparm) - eello_turn3=enetb(8,i,iparm) - eello_turn4=enetb(9,i,iparm) - eello_turn6=enetb(10,i,iparm) - ebe=enetb(11,i,iparm) - escloc=enetb(12,i,iparm) - etors=enetb(13,i,iparm) - etors_d=enetb(14,i,iparm) - ehpb=enetb(15,i,iparm) - - estr=enetb(17,i,iparm) -! estr=enetb(18,i,iparm) -! esccor=enetb(19,i,iparm) - esccor=enetb(21,i,iparm) -! edihcnstr=enetb(20,i,iparm) - edihcnstr=enetb(19,i,iparm) -!#ifdef SPLITELE -! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & -! +wvdwpp*evdw1 & -! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & -! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & -! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & -! +ft(2)*wturn3*eello_turn3 & -! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc & -! +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & -! +wbond*estr -!#else -! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & -! +ft(1)*welec*(ees+evdw1) & -! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & -! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & -! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & -! +ft(2)*wturn3*eello_turn3 & -! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr & -! +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & -! +wbond*estr -!#endif - -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees & - +wvdwpp*evdw1 & - +wang*ebe+wtor*etors+wscloc*escloc & - +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & - +wcorr6*ecorr6+wturn4*eello_turn4 & - +wturn3*eello_turn3 & - +wturn6*eello_turn6+wel_loc*eel_loc & - +edihcnstr+wtor_d*etors_d+wsccor*esccor & - +wbond*estr -#else - etot=wsc*evdw+wscp*evdw2 & - +welec*(ees+evdw1) & - +wang*ebe+wtor*etors+wscloc*escloc & - +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & - +wcorr6*ecorr6+wturn4*eello_turn4 & - +wturn3*eello_turn3 & - +wturn6*eello_turn6+wel_loc*eel_loc+edihcnstr & - +wtor_d*etors_d+wsccor*esccor & - +wbond*estr -#endif - -#ifdef MPI - Fdimless(i)= & - beta_h(ib,iparm)*etot-entfac(i) - potE(i,iparm)=etot -#ifdef DEBUG - write (iout,*) i,indstart(me)+i-1,ib,& - 1.0d0/(1.987d-3*beta_h(ib,iparm)),potE(i,iparm),& - -entfac(i),Fdimless(i) -#endif -#else - Fdimless(i)=beta_h(ib,iparm)*etot-entfac(i) - potE(i,iparm)=etot -#endif - enddo ! i -#ifdef MPI - do i=1,scount(me1) - Fdimless_(i)=Fdimless(i) - enddo - call MPI_Gatherv(Fdimless_(1),scount(me),& - MPI_REAL,Fdimless(1),& - scount_(0),idispl(0),MPI_REAL,Master,& - WHAM_COMM, IERROR) -#ifdef DEBUG - call MPI_Gatherv(potE(1,iparm),scount_(me),& - MPI_DOUBLE_PRECISION,potE(1,iparm),& - scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& - WHAM_COMM, IERROR) - call MPI_Gatherv(entfac(1),scount(me),& - MPI_DOUBLE_PRECISION,entfac(1),& - scount_(0),idispl(0),MPI_DOUBLE_PRECISION,Master,& - WHAM_COMM, IERROR) -#endif - if (me.eq.Master) then -#ifdef DEBUG - write (iout,*) "The FDIMLESS array before sorting" - do i=1,ntot(islice) - write (iout,*) i,fdimless(i) - enddo -#endif -#endif - do i=1,ntot(islice) - iperm(i)=i - enddo - call mysort1(ntot(islice),Fdimless,iperm) -#ifdef DEBUG - write (iout,*) "The FDIMLESS array after sorting" - do i=1,ntot(islice) - write (iout,*) i,iperm(i),fdimless(i) - enddo -#endif - qfree=0.0d0 - do i=1,ntot(islice) - qfree=qfree+exp(-fdimless(i)+fdimless(1)) - enddo -! write (iout,*) "qfree",qfree - nlist=1 - sumprob=0.0 - do i=1,min0(ntot(islice),ensembles) - sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree -#ifdef DEBUG - write (iout,*) i,ib,beta_h(ib,iparm),& - 1.0d0/(1.987d-3*beta_h(ib,iparm)),iperm(i),& - potE(iperm(i),iparm),& - -entfac(iperm(i)),fdimless(i),sumprob -#endif - if (sumprob.gt.0.99d0) goto 122 - nlist=nlist+1 - enddo - 122 continue -#ifdef MPI - endif - call MPI_Bcast(nlist, 1, MPI_INTEGER, Master, WHAM_COMM,& - IERROR) - call MPI_Bcast(iperm,nlist,MPI_INTEGER,Master,WHAM_COMM,& - IERROR) - do i=1,nlist - ii=iperm(i) - iproc=0 - do while (ii.lt.indstart(iproc).or.ii.gt.indend(iproc)) - iproc=iproc+1 - enddo - if (iproc.ge.nprocs) then - write (iout,*) "Fatal error: processor out of range",iproc - call flush(iout) - if (bxfile) then - close (ientout) - else - close (ientout,status="delete") - endif - return 1 - endif - ik=ii-indstart(iproc)+1 - if (iproc.ne.Master) then - if (me.eq.iproc) then -#ifdef DEBUG - write (iout,*) "i",i," ii",ii," iproc",iproc," ik",ik,& - " energy",potE(ik,iparm) -#endif - call MPI_Send(potE(ik,iparm),1,MPI_DOUBLE_PRECISION,& - Master,i,WHAM_COMM,IERROR) - else if (me.eq.Master) then - call MPI_Recv(enepot(i),1,MPI_DOUBLE_PRECISION,iproc,i,& - WHAM_COMM,STATUS,IERROR) - endif - else if (me.eq.Master) then - enepot(i)=potE(ik,iparm) - endif - enddo -#else - do i=1,nlist - enepot(i)=potE(iperm(i),iparm) - enddo -#endif -#ifdef MPI - if (me.eq.Master) then -#endif - write(licz3,'(bz,i3.3)') iparm - write(licz2,'(bz,i2.2)') islice - if (temper.lt.100.0d0) then - write(ctemper,'(f3.0)') temper - else if (temper.lt.1000.0) then - write (ctemper,'(f4.0)') temper - else - write (ctemper,'(f5.0)') temper - endif - if (nparmset.eq.1) then - if (separate_parset) then - write(licz4,'(bz,i3.3)') myparm - pdbname=prefix(:ilen(prefix))//"_par"//licz4 - else - pdbname=prefix(:ilen(prefix)) - endif - else - pdbname=prefix(:ilen(prefix))//"_parm_"//licz3 - endif - if (nslice.eq.1) then - pdbname=pdbname(:ilen(pdbname))//"_T_"// & - ctemper(:ilen(ctemper))//"pdb" - else - pdbname=pdbname(:ilen(pdbname))//"_slice_"//licz2//"_T_"// & - ctemper(:ilen(ctemper))//"pdb" - endif - open(ipdb,file=pdbname) - do i=1,nlist - read (ientout,rec=iperm(i)) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,iscor - do j=1,2*nres - do k=1,3 - c(k,j)=csingle(k,j) - enddo - enddo - eini=fdimless(i) - call pdboutW(iperm(i),temper,eini,enepot(i),efree,rmsdev) - enddo -#ifdef MPI - endif -#endif - enddo ! ib - enddo ! iparm - if (bxfile) then - close(ientout) - else - close(ientout,status="delete") - endif - do i=0,nprocs - scount(i)=scount_(i) - enddo - return - end subroutine make_ensembles -!-------------------------------------------------------------------------- - subroutine mysort1(n, x, ipermut) -! implicit none - integer :: i,j,imax,ipm,n - real(kind=4) :: x(n) - integer :: ipermut(n) - real(kind=4) :: xtemp - do i=1,n - xtemp=x(i) - imax=i - do j=i+1,n - if (x(j).lt.xtemp) then - imax=j - xtemp=x(j) - endif - enddo - x(imax)=x(i) - x(i)=xtemp - ipm=ipermut(imax) - ipermut(imax)=ipermut(i) - ipermut(i)=ipm - enddo - return - end subroutine mysort1 -!-------------------------------------------------------------------------- - subroutine alloc_enecalc_arrays(iparm) - - use control_data - use geometry_data, only:maxlob - integer :: iparm -!--------------------------- -! COMMON.ENERGIES form wham_data -! common /energies/ - allocate(potE(MaxStr_Proc,iparm)) !(MaxStr_Proc,Max_Parm) - allocate(entfac(MaxStr_Proc)) !(MaxStr_Proc) - allocate(q(nQ+2,MaxStr_Proc)) !(MaxQ+2,MaxStr_Proc) - allocate(enetb(max_ene,MaxStr_Proc,iparm)) !(max_ene,MaxStr_Proc,Max_Parm) -! -! allocate ENECALC arrays -!--------------------------- -! COMMON.ALLPARM -! common /allparm/ - allocate(ww_all(max_eneW,iparm)) !(max_ene,max_parm) ! max_eneW - allocate(vbldp0_all(iparm),akp_all(nParmSet)) !(max_parm) - allocate(vbldsc0_all(maxbondterm,ntyp,iparm),& - aksc_all(maxbondterm,ntyp,iparm),& - abond0_all(maxbondterm,ntyp,iparm)) !(maxbondterm,ntyp,max_parm) - allocate(a0thet_all(-ntyp:ntyp,iparm)) !(-ntyp:ntyp,max_parm) - allocate(athet_all(2,-ntyp:ntyp,-1:1,-1:1,iparm),& - bthet_all(2,-ntyp:ntyp,-1:1,-1:1,iparm)) !(2,-ntyp:ntyp,-1:1,-1:1,max_parm) - allocate(polthet_all(0:3,-ntyp:ntyp,iparm)) !(0:3,-ntyp:ntyp,max_parm) - allocate(gthet_all(3,-ntyp:ntyp,iparm)) !(3,-ntyp:ntyp,max_parm) - allocate(theta0_all(-ntyp:ntyp,iparm),& - sig0_all(-ntyp:ntyp,iparm),sigc0_all(-ntyp:ntyp,nParmSet)) !(-ntyp:ntyp,max_parm) - allocate(aa0thet_all(-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) -!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) - allocate(aathet_all(maxtheterm,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) -!(maxtheterm,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) - allocate(bbthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) - allocate(ccthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) - allocate(ddthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) - allocate(eethet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,iparm)) -!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, -! & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm) - allocate(ffthet_all1(maxdouble,maxdouble,maxtheterm3,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,iparm)) - allocate(ggthet_all1(maxdouble,maxdouble,maxtheterm3,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,iparm)) - allocate(ffthet_all2(maxdouble,maxdouble,maxtheterm3,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,iparm)) - allocate(ggthet_all2(maxdouble,maxdouble,maxtheterm3,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,iparm)) -!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,& -!-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,max_parm) - allocate(dsc_all(ntyp1,iparm),dsc0_all(ntyp1,nParmSet)) !(ntyp1,max_parm) - allocate(bsc_all(maxlob,ntyp,iparm)) -!(maxlob,ntyp,max_parm) - allocate(censc_all(3,maxlob,-ntyp:ntyp,iparm)) !(3,maxlob,-ntyp:ntyp,max_parm) - allocate(gaussc_all(3,3,maxlob,-ntyp:ntyp,iparm)) !(3,3,maxlob,-ntyp:ntyp,max_parm) - allocate(sc_parmin_all(65,ntyp,iparm)) !(65,ntyp,max_parm) - allocate(v0_all(-maxtor:maxtor,-maxtor:maxtor,2,iparm)) -!(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(v1_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,iparm)) - allocate(v2_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,iparm)) -!(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(vlor1_all(maxlor,maxtor,maxtor,iparm)) - allocate(vlor2_all(maxlor,maxtor,maxtor,iparm)) - allocate(vlor3_all(maxlor,maxtor,maxtor,iparm)) !(maxlor,maxtor,maxtor,max_parm) - allocate(v1c_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,& - -maxtor:maxtor,2,iparm)) - allocate(v1s_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,& - -maxtor:maxtor,2,iparm)) -!(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(v2c_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,& - -maxtor:maxtor,-maxtor:maxtor,2,iparm)) -!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(v2s_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,& - -maxtor:maxtor,-maxtor:maxtor,2,iparm)) -!(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(b1_all(2,-maxtor:maxtor,iparm)) - allocate(b2_all(2,-maxtor:maxtor,iparm)) !(2,-maxtor:maxtor,max_parm) - allocate(cc_all(2,2,-maxtor:maxtor,iparm)) - allocate(dd_all(2,2,-maxtor:maxtor,iparm)) - allocate(ee_all(2,2,-maxtor:maxtor,iparm)) !(2,2,-maxtor:maxtor,max_parm) - allocate(ctilde_all(2,2,-maxtor:maxtor,iparm)) - allocate(dtilde_all(2,2,-maxtor:maxtor,iparm)) !(2,2,-maxtor:maxtor,max_parm) - allocate(b1tilde_all(2,-maxtor:maxtor,iparm)) !(2,-maxtor:maxtor,max_parm) - allocate(app_all(2,2,iparm),bpp_all(2,2,nParmSet),& - ael6_all(2,2,iparm),ael3_all(2,2,nParmSet)) !(2,2,max_parm) - allocate(aad_all(ntyp,2,iparm),bad_all(ntyp,2,nParmSet)) !(ntyp,2,max_parm) - allocate(aa_all(ntyp,ntyp,iparm),bb_all(ntyp,ntyp,nParmSet),& - augm_all(ntyp,ntyp,iparm),eps_all(ntyp,ntyp,nParmSet),& - sigma_all(ntyp,ntyp,iparm),r0_all(ntyp,ntyp,nParmSet),& - chi_all(ntyp,ntyp,iparm)) !(ntyp,ntyp,max_parm) - allocate(chip_all(ntyp,iparm),alp_all(ntyp,nParmSet)) !(ntyp,max_parm) - allocate(ebr_all(iparm),d0cm_all(nParmSet),akcm_all(nParmSet),& - akth_all(iparm),akct_all(nParmSet),v1ss_all(nParmSet),& - v2ss_all(iparm),v3ss_all(nParmSet)) !(max_parm) - allocate(v1sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,iparm)) - allocate(v2sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,iparm)) -!(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm) - allocate(nlob_all(ntyp1,iparm)) !(ntyp1,max_parm) - allocate(nlor_all(-maxtor:maxtor,-maxtor:maxtor,2,iparm)) - allocate(nterm_all(-maxtor:maxtor,-maxtor:maxtor,2,iparm)) -!(-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(ntermd1_all(-maxtor:maxtor,-maxtor:maxtor,& - -maxtor:maxtor,2,iparm)) - allocate(ntermd2_all(-maxtor:maxtor,-maxtor:maxtor,& - -maxtor:maxtor,2,iparm)) -!(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2,max_parm) - allocate(nbondterm_all(ntyp,iparm)) !(ntyp,max_parm) - allocate(ithetyp_all(-ntyp1:ntyp1,iparm)) !(-ntyp1:ntyp1,max_parm) - allocate(nthetyp_all(iparm),ntheterm_all(nParmSet),& - ntheterm2_all(iparm),ntheterm3_all(nParmSet),& - nsingle_all(iparm),& - ndouble_all(iparm),nntheterm_all(nParmSet)) !(max_parm) - allocate(nterm_sccor_all(-ntyp:ntyp,-ntyp:ntyp,iparm)) !(-ntyp:ntyp,-ntyp:ntyp,max_parm) -! - end subroutine alloc_enecalc_arrays -!-------------------------------------------------------------------------- -!-------------------------------------------------------------------------- - end module ene_calc diff --git a/source/wham/io_database.F90 b/source/wham/io_database.F90 new file mode 100644 index 0000000..13d4f37 --- /dev/null +++ b/source/wham/io_database.F90 @@ -0,0 +1,1488 @@ + module io_database +!----------------------------------------------------------------------------- + use names + use wham_data + use io_units + use io_base, only:ilen + use energy_data, only:nnt,nct,nss,ihpb,jhpb,iset + use geometry_data, only:nres,c +#ifdef MPI + use MPI_data +! include "COMMON.MPI" +#endif + + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! readrtns.F +!------------------------------------------------------------------------------- + subroutine opentmp(islice,iunit,bprotfile_temp) +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! use MPI_data, only:me +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.PROT" +! include "COMMON.FREE" + character(len=64) :: bprotfile_temp + character(len=3) :: liczba,liczba2 + character(len=2) :: liczba1 + integer :: iunit,islice +! integer ilen,iroof +! external ilen,iroof +! logical :: lerr +! integer :: lenrec,lenrec2 + +!el +! lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ +! lenrec=lenrec2+8 + write (liczba1,'(bz,i2.2)') islice +#ifdef MPI + write (liczba,'(bz,i3.3)') me +!#ifdef MPI +! write (iout,*) "separate_parset ",separate_parset, +! & " myparm",myparm + if (separate_parset) then + write (liczba2,'(bz,i3.3)') myparm + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & + prefix(:ilen(prefix))//liczba//"_"//liczba2//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown",& + form="unformatted",access="direct",recl=lenrec) + else + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & + prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown",& + form="unformatted",access="direct",recl=lenrec) + endif +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// & + "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown",& + form="unformatted",access="direct",recl=lenrec) +#endif +! write (iout,*) "OpenTmp iunit",iunit," bprotfile_temp", +! & bprotfile_temp +! call flush(iout) + return + end subroutine opentmp +!------------------------------------------------------------------------------- + subroutine read_database(*) + +! use energy_data, only:nct,nnt,nss +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" + use MPI_data, only:me,nprocs +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.GEO" +! include "COMMON.ENEPS" +! include "COMMON.PROT" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.SBRIDGE" +! include "COMMON.OBCINKA" + real(kind=4) :: csingle(3,nres*2) !(3,maxres2) + character(len=64) :: nazwa,bprotfile_temp + character(len=3) :: liczba + character(len=2) :: liczba1 + integer :: i,j,ii,jj(nslice),k,kk(nslice),l,& + ll(nslice),mm(nslice),if + integer :: nrec,nlines,iscor,iunit,islice + real(kind=8) :: energ +! integer ilen,iroof +! external ilen,iroof + real(kind=8) :: rmsdev,energia(0:n_ene),efree,eini,temp +!el real(kind=8) :: rmsdev,energia(0:max_eneW),efree,eini,temp + real(kind=8) :: prop(nQ) !(maxQ) + integer :: ntot_all(nslice,0:nprocs-1)!(maxslice,0:maxprocs-1) + integer :: iparm,ib,iib,ir,nprop,nthr,npars + real(kind=8) :: etot,time + integer :: ixdrf,iret + logical :: lerr,linit + + lenrec1=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 + lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ + lenrec=lenrec2+8 + write (iout,*) "lenrec",lenrec," lenrec1",lenrec1,& + " lenrec2",lenrec2 + + do i=1,nQ + prop(i)=0.0d0 + enddo + do islice=1,nslice + ll(islice)=0 + mm(islice)=0 + enddo + write (iout,*) "nparmset",nparmset + if (hamil_rep) then + npars=1 + else + npars=nparmset + endif + do iparm=1,npars + + if (replica(iparm)) then + nthr = 1 + else + nthr = nT_h(iparm) + endif + + do ib=1,nthr + do iR=1,nRR(ib,iparm) + + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ + do islice=1,nslice + jj(islice)=0 + kk(islice)=0 + enddo + + IF (NFILE_BIN(iR,ib,iparm).GT.0) THEN +! Read conformations from binary DA files (one per batch) and write them to +! a binary DA scratchfile. + write (liczba,'(bz,i3.3)') me + do if=1,nfile_bin(iR,ib,iparm) + nazwa=protfiles(if,1,iR,ib,iparm) & + (:ilen(protfiles(if,1,iR,ib,iparm)))//".bx" + open (ientin,file=nazwa,status="old",form="unformatted",& + access="direct",recl=lenrec2,err=1111) + ii=0 + do islice=1,nslice + call opentmp(islice,ientout,bprotfile_temp) + call bxread(nazwa,islice,ii,jj(islice),kk(islice),ll(islice),& + mm(islice),iR,ib,iparm) + close(ientout) + enddo + close(ientin) + enddo + ENDIF ! NFILE_BIN>0 +! + IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN +! Read conformations from multiple ASCII int files and write them to a binary +! DA scratchfile. + do if=1,nfile_asc(iR,ib,iparm) + nazwa=protfiles(if,2,iR,ib,iparm) & + (:ilen(protfiles(if,2,iR,ib,iparm)))//".x" + open(unit=ientin,file=nazwa,status='old',err=1111) + write(iout,*) "reading ",nazwa(:ilen(nazwa)) + ii=0 + call xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) + enddo ! if + ENDIF + IF (NFILE_CX(iR,ib,iparm).gt.0) THEN +! Read conformations from cx files and write them to a binary +! DA scratchfile. + do if=1,nfile_cx(iR,ib,iparm) + nazwa=protfiles(if,2,iR,ib,iparm) & + (:ilen(protfiles(if,2,iR,ib,iparm)))//".cx" + write(iout,*) "reading ",nazwa(:ilen(nazwa)) + ii=0 + print *,"Calling cxread" + call cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,& + *1111) +write(iout,*)"after call cxread" + close(ientout) + write (iout,*) "exit cxread" + call flush(iout) + enddo + ENDIF +write(iout,*)"*********************in read database" + + do islice=1,nslice +! stot(islice)=0 + stot(islice)=stot(islice)+jj(islice) + enddo + + enddo + enddo + write (iout,*) "IPARM",iparm + enddo + + if (nslice.eq.1) then +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & + prefix(:ilen(prefix))//liczba//".xbin.tmp" +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// & + "/"//prefix(:ilen(prefix))//".xbin.tmp" +#endif + write(iout,*) mm(1)," conformations read",ll(1),& + " conformations written to ",& + bprotfile_temp(:ilen(bprotfile_temp)) + else + do islice=1,nslice + write (liczba1,'(bz,i2.2)') islice +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & + prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// & + "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 +#endif + write(iout,*) mm(islice)," conformations read",ll(islice),& + " conformations written to ",& + bprotfile_temp(:ilen(bprotfile_temp)) + enddo + endif + +#ifdef MPI +! Check if everyone has the same number of conformations + call MPI_Allgather(stot(1),nslice,MPI_INTEGER,& + ntot_all(1,0),nslice,MPI_INTEGER,MPI_Comm_World,IERROR) + lerr=.false. + do i=0,nprocs-1 + if (i.ne.me) then + do islice=1,nslice + if (stot(islice).ne.ntot_all(islice,i)) then + write (iout,*) "Number of conformations at processor",i,& + " differs from that at processor",me,& + stot(islice),ntot_all(islice,i)," slice",islice + lerr = .true. + endif + enddo + endif + enddo + if (lerr) then + write (iout,*) + write (iout,*) "Numbers of conformations read by processors" + write (iout,*) + do i=0,nprocs-1 + write (iout,'(8i10)') i,(ntot_all(islice,i),islice=1,nslice) + enddo + write (iout,*) "Calculation terminated." + call flush(iout) + return 1 + endif + do islice=1,nslice + ntot(islice)=stot(islice) + enddo +write(iout,*) "end of read database" + return +#endif + 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) + call flush(iout) + return 1 + end subroutine read_database +!-------------------------------------------------------------------------------- + integer function iroof(n,m) + integer :: n,m,ii + ii = n/m + if (ii*m .lt. n) ii=ii+1 + iroof = ii + return + end function iroof +!-------------------------------------------------------------------------------- +! bxread.F +!-------------------------------------------------------------------------------- + subroutine bxread(nazwa,islice,ii,jj,kk,ll,mm,iR,ib,iparm) +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! use energy_data, only:nnt,nct,nss,ihpb,jhpbi + use MPI_data, only:nprocs +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.GEO" +! include "COMMON.ENEPS" +! include "COMMON.PROT" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.SBRIDGE" + real(kind=4) :: csingle(3,nres*2) !(3,maxres2) + character(len=64) :: nazwa,bprotfile_temp + character(len=3) :: liczba + integer :: i,is,ie,j,ii,jj,k,kk,l,ll,mm,if + integer :: nrec,nlines,iscor,islice + real(kind=8) :: energ +! integer ilen,iroof +! external ilen,iroof + real(kind=8) :: rmsdev,energia(0:n_ene),efree,eini,temp +!el real(kind=8) :: rmsdev,energia(0:max_eneW),efree,eini,temp + real(kind=8) :: prop(nQ) !(maxQ) + integer :: ntot_all(0:nprocs-1)!(0:maxprocs-1) + integer :: iparm,ib,iib,ir,nprop,nthr,nrec_slice + real(kind=8) :: etot,time + logical :: lerr + nrec_slice=(rec_end(iR,ib,iparm)-rec_start(iR,ib,iparm)+1)/nslice + is=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice + ie=rec_start(iR,ib,iparm)+islice*nrec_slice-1 + write (iout,*) "bxread: islice",islice," nslice",nslice,& + " nrec_slice",nrec_slice + write (iout,*) "is",is," ie",ie,"rec_start",& + rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) + do i=is,ie + read(ientin,rec=i+1,err=101) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,(prop(j),j=1,nQ),iscor + ii=ii+1 + kk=kk+1 + if (mod(kk,isampl(iparm)).eq.0) then + jj=jj+1 + write(ientout,rec=jj) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,(prop(j),j=1,nQ),iR,ib,iparm +#ifdef DEBUG + do i=1,2*nres + do j=1,3 + c(j,i)=csingle(j,i) + enddo + enddo + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",jj + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(f10.5,i5)') rmsdev,iscor +#endif + endif + enddo + 101 continue + close(ientin) + write (iout,*) ii," conformations read from DA file ",& + nazwa(:ilen(nazwa)) + write (iout,*) kk," conformations read so far, slice",islice + write (iout,*) jj," conformations stored so far, slice",islice + + return + end subroutine bxread +!-------------------------------------------------------------------------------- +! cxread.F +!-------------------------------------------------------------------------------- + subroutine cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,*) + +#define DEBUG +#ifdef DEBUG + use geometry, only:int_from_cart1 + use geometry_data, only:vbld,rad2deg,theta,phi,alph,omeg + integer :: iscor +#endif +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.FREE' + integer,parameter :: MaxTraj=2050 +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' +! include 'COMMON.PROTFILES' +! include 'COMMON.OBCINKA' +! include 'COMMON.FREE' +! include 'COMMON.VAR' +! include 'COMMON.GEO' +! include 'COMMON.PROT' + character(len=64) :: nazwa,bprotfile_temp + real(kind=4) :: rtime,rpotE,ruconst,rt_bath,rprop(nQ) !(2000) !(maxQ) + real(kind=8) :: time + integer :: iret,itmp,itraj,ntraj + real(kind=4) :: xoord(3,2*nres+2),prec + integer :: nstep(0:MaxTraj-1) +! integer ilen +! external ilen + integer :: ii,jj(nslice),kk(nslice),ll(nslice),mm(nslice) !(maxslice) + integer :: is(nSlice),ie(nSlice),nrec_slice + real(kind=8) :: ts(nSlice),te(nSlice),time_slice + integer :: iR,ib,iparm,i,j,it,islice,nprop_prev + integer :: k,l,iib,islice1,nprop + real(kind=8) :: efree,rmsdev + integer :: ixdrf +!el integer :: slice +! logical :: conf_check +! ixdrf=0 +! nprop=0 + +! ruconst=0.0d0 +! rtime=0.0d0 +! rpotE=0.0d0 +! rt_bath=0.0d0 + + call set_slices(is,ie,ts,te,iR,ib,iparm) + nprop_prev=0 + do i=1,nQ + rprop(i)=0.0d0 + enddo + do i=0,MaxTraj-1 + nstep(i)=0 + enddo + ntraj=0 + it=0 + iret=1 +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,nazwa, "r", iret) +#else + call xdrfopen(ixdrf,nazwa, "r", iret) +#endif + if (iret.eq.0) return 1 + + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) + print *,"bumbum" !d + do while (iret.gt.0) + +#if (defined(AIX) && !defined(JUBL)) + call xdrffloat_(ixdrf, rtime, iret) + print *,"rtime",rtime," iret",iret !d + call xdrffloat_(ixdrf, rpotE, iret) + write (iout,*) "rpotE",rpotE," iret",iret !d + call flush(iout) + call xdrffloat_(ixdrf, ruconst, iret) + call xdrffloat_(ixdrf, rt_bath, iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + enddo + call xdrfint_(ixdrf, nprop, iret) + if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) & + call xdrfint(ixdrf, iset, iret) + do i=1,nprop + call xdrffloat_(ixdrf, rprop(i), iret) + enddo +#else + call xdrffloat(ixdrf, rtime, iret) + call xdrffloat(ixdrf, rpotE, iret) + write (iout,*) "rpotE",rpotE," iret",iret !d + call flush(iout) + call xdrffloat(ixdrf, ruconst, iret) + call xdrffloat(ixdrf, rt_bath, iret) + call xdrfint(ixdrf, nss, iret) + do j=1,nss + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + enddo + call xdrfint(ixdrf, nprop, iret) + write (iout,*) "nprop",nprop !d + if (it.gt.0 .and. nprop.ne.nprop_prev) then + write (iout,*) "Warning previous nprop",nprop_prev,& + " current",nprop + nprop=nprop_prev + else + nprop_prev=nprop + endif + call flush(iout) + if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) & + call xdrfint(ixdrf, iset, iret) + do i=1,nprop + call xdrffloat(ixdrf, rprop(i), iret) + enddo +#endif + if (iret.eq.0) exit + itraj=mod(it,totraj(iR,iparm)) +#define DEBUG +#ifdef DEBUG + write (iout,*) "ii",ii," itraj",itraj," it",it +#endif + if (iset.eq.0) iset = 1 + call flush(iout) + it=it+1 + if (itraj.gt.ntraj) ntraj=itraj + nstep(itraj)=nstep(itraj)+1 +! rprop(2)=dsqrt(rprop(2)) +! rprop(3)=dsqrt(rprop(3)) +#ifdef DEBUG + write (iout,*) "umbrella ",umbrella + write (iout,*) rtime,rpotE,rt_bath,nss,& + (ihpb(j),jhpb(j),j=1,nss),(rprop(j),j=1,nprop) + write (iout,*) "nprop",nprop," iset",iset," myparm",myparm + call flush(iout) +#endif + prec=10000.0 + itmp=0 +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) +#else + call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) +#endif +#ifdef DEBUG + write (iout,'(10f8.3)') ((xoord(j,i),j=1,3),i=1,2*nres+2) +#endif +#undef DEBUG + if (iret.eq.0) exit + if (itmp .ne. nres + nct - nnt + 1) then + write (iout,*) "Error: inconsistent sizes",itmp,nres+nct-nnt+1 + call flush(iout) + exit + endif + + time=rtime + write (iout,*) "calling slice" !d + call flush(iout) !d + islice=slice(nstep(itraj),time,is,ie,ts,te) + write (iout,*) "islice",islice !d + call flush(iout) !d + + do i=1,nres + do j=1,3 + c(j,i)=xoord(j,i) + enddo + enddo + do i=1,nct-nnt+1 + do j=1,3 + c(j,i+nres+nnt-1)=xoord(j,i+nres) + enddo + enddo + + if (islice.gt.0 .and. islice.le.nslice .and. (.not.separate_parset & + .or. iset.eq.myparm)) then + ii=ii+1 + kk(islice)=kk(islice)+1 + mm(islice)=mm(islice)+1 + if (mod(nstep(itraj),isampl(iparm)).eq.0 .and. & + conf_check(ll(islice)+1,1)) then + if (replica(iparm)) then + rt_bath=1.0d0/(rt_bath*1.987D-3) + do i=1,nT_h(iparm) + if (abs(real(beta_h(i,iparm))-rt_bath).lt.1.0e-4) then + iib = i + goto 22 + endif + enddo + 22 continue + if (i.gt.nT_h(iparm)) then + write (iout,*) "Error - temperature of conformation",& + ii,1.0d0/(rt_bath*1.987D-3),& + " does not match any of the list" + write (iout,*) & + 1.0d0/(rt_bath*1.987D-3),& + (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + call flush(iout) +! exit +! call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) + ii=ii-1 + kk(islice)=kk(islice)-1 + mm(islice)=mm(islice)-1 + goto 112 + endif + else + iib = ib + endif + + efree=0.0d0 + jj(islice)=jj(islice)+1 + if (umbrella(iparm)) then + snk(iset,iib,iparm,islice)=snk(iset,iib,iparm,islice)+1 + else if (hamil_rep) then + snk(1,iib,iparm,islice)=snk(1,iib,iparm,islice)+1 + else + snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 + endif + ll(islice)=ll(islice)+1 +#ifdef DEBUG + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "ib",ib," iib",iib + write (iout,*) "ntraj",ntraj," itraj",itraj,& + " nstep",nstep(itraj) + write (iout,*) "pote",rpotE," time",rtime +! if (replica(iparm)) then +! write (iout,*) "TEMP",1.0d0/(rt_bath*1.987D-3) +! write (iout,*) "TEMP list" +! write (iout,*) +! & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) +! endif + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +! write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +! write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 + call flush(iout) +#endif + if (islice.ne.islice1) then +! write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +! write (iout,*) "Closing file ", +! & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +! write (iout,*) "Opening file ", +! & bprotfile_temp(:ilen(bprotfile_temp)) + islice1=islice + endif + if (umbrella(iparm)) then + write(ientout,rec=ll(islice)) & + ((xoord(l,k),l=1,3),k=1,nres),& + ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ),& + iset,iib,iparm + else if (hamil_rep) then + write(ientout,rec=ll(islice)) & + ((xoord(l,k),l=1,3),k=1,nres),& + ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ),& + iR,iib,iset + else + write(ientout,rec=ll(islice)) & + ((xoord(l,k),l=1,3),k=1,nres),& + ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ),& + iR,iib,iparm + endif +#ifdef DEBUG + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) +! write (iout,'(8f10.5)') (rprop(j),j=1,nQ) + write (iout,'(16i5)') iscor + call flush(iout) +#endif + endif + endif + + 112 continue + + enddo + close(ientout) +#if (defined(AIX) && !defined(JUBL)) + call xdrfclose_(ixdrf, iret) +#else + call xdrfclose(ixdrf, iret) +#endif + write (iout,'(i10," trajectories found in file.")') ntraj+1 + write (iout,'(a)') "Numbers of steps in trajectories:" + write (iout,'(8i10)') (nstep(i),i=0,ntraj) + write (iout,*) ii," conformations read from file",& + nazwa(:ilen(nazwa)) + do islice=1,nslice + write (iout,*) mm(islice)," conformations read so far, slice",& + islice + write (iout,*) ll(islice),& + " conformations stored so far, slice",islice + enddo + call flush(iout) +#undef DEBUG + return + end subroutine cxread +!-------------------------------------------------------------------------------- +! xread.F +!-------------------------------------------------------------------------------- + subroutine xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) + + use geometry_data +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" + use MPI_data, only:nprocs +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif + integer,parameter :: MaxTraj=2050 +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.GEO" +! include "COMMON.ENEPS" +! include "COMMON.PROT" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.SBRIDGE" +! include "COMMON.OBCINKA" + real(kind=4) :: csingle(3,nres*2) + character(len=64) :: nazwa,bprotfile_temp + integer :: i,j,k,l,ii,jj(nslice),kk(nslice),ll(nslice),& + mm(nslice) !(maxslice) + integer :: iscor,islice,islice1 !el,slice + real(kind=8) :: energ +! integer ilen,iroof +! external ilen,iroof + real(kind=8) :: rmsdev,energia(0:n_ene),efree,eini,temp +!el real(kind=8) :: rmsdev,energia(0:max_eneW),efree,eini,temp + real(kind=8) :: prop(nQ) !(maxQ) + integer :: ntot_all(0:nprocs-1)!(0:maxprocs-1) + integer :: iparm,ib,iib,ir,nprop,nthr + real(kind=8) :: etot,time,ts(nslice),te(nslice) + integer :: is(nslice),ie(nslice),itraj,ntraj,it,iset + integer :: nstep(0:MaxTraj-1) + logical :: lerr + + call set_slices(is,ie,ts,te,iR,ib,iparm) + do i=1,nQ + prop(i)=0.0d0 + enddo + do i=0,MaxTraj-1 + nstep(i)=0 + enddo + ntraj=0 + it=0 + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) + do while (.true.) + if (replica(iparm)) then + if (hamil_rep .or. umbrella(iparm)) then + read (ientin,*,end=1112,err=1112) time,eini,& + etot,temp,nss,(ihpb(j),jhpb(j),j=1,nss),& + nprop,(prop(j),j=1,nprop),iset + else + read (ientin,*,end=1112,err=1112) time,eini,& + etot,temp,nss,(ihpb(j),jhpb(j),j=1,nss),& + nprop,(prop(j),j=1,nprop) + endif + temp=1.0d0/(temp*1.987D-3) +! write (iout,*) time,eini,etot,nss, +! & (ihpb(j),jhpb(j),j=1,nss),(prop(j),j=1,nprop) +! call flush(iout) + do i=1,nT_h(iparm) + if (beta_h(i,iparm).eq.temp) then + iib = i + goto 22 + endif + enddo + 22 continue + if (i.gt.nT_h(iparm)) then + write (iout,*) "Error - temperature of conformation",& + ii,1.0d0/(temp*1.987D-3),& + " does not match any of the list" + write (iout,*) & + 1.0d0/(temp*1.987D-3),& + (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + call flush(iout) +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + endif + else + read (ientin,*,end=1112,err=1112) time,eini,& + etot,nss,(ihpb(j),jhpb(j),j=1,nss),& + nprop,(prop(j),j=1,nprop) + iib = ib + endif + itraj=mod(it,totraj(iR,iparm)) +! write (*,*) "ii",ii," itraj",itraj +! call flush(iout) + it=it+1 + if (itraj.gt.ntraj) ntraj=itraj + nstep(itraj)=nstep(itraj)+1 + islice=slice(nstep(itraj),time,is,ie,ts,te) + read (ientin,'(8f10.5)',end=1112,err=1112) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct) + efree=0.0d0 + if (islice.gt.0 .and. islice.le.nslice) then + ii=ii+1 + kk(islice)=kk(islice)+1 + mm(islice)=mm(islice)+1 + if (mod(nstep(itraj),isampl(iparm)).eq.0) then + jj(islice)=jj(islice)+1 + if (hamil_rep) then + snk(iR,iib,iset,islice)=snk(iR,iib,iset,islice)+1 + else if (umbrella(iparm)) then + snk(iset,iib,iparm,islice)=snk(iset,iib,iparm,islice)+1 + else + snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 + endif + ll(islice)=ll(islice)+1 +! write (iout,*) ii,kk,jj,ll,eini,(prop(j),j=1,nprop) +#ifdef DEBUG +! write (iout,*) "Writing conformation, record",ll(islice) +! write (iout,*) "ib",ib," iib",iib + if (replica(iparm)) then + write (iout,*) "TEMP",1.0d0/(temp*1.987D-3) + write (iout,*) "TEMP list" + write (iout,*) & + (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + endif + call flush(iout) +#endif +! write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +! write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +! write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 +! call flush(iout) + if (islice.ne.islice1) then +! write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +! write (iout,*) "Closing file ", +! & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +! write (iout,*) "Opening file ", +! & bprotfile_temp(:ilen(bprotfile_temp)) +! call flush(iout) + islice1=islice + endif + write(ientout,rec=ll(islice)) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,(prop(i),i=1,nQ),iR,iib,iparm +#ifdef DEBUG + do i=1,2*nres + do j=1,3 + c(j,i)=csingle(j,i) + enddo + enddo + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) +! write (iout,'(8f10.5)') (prop(j),j=1,nQ) + write (iout,'(16i5)') iscor + call flush(iout) +#endif + endif + endif + enddo + 1112 continue + close(ientout) + write (iout,'(i10," trajectories found in file.")') ntraj+1 + write (iout,'(a)') "Numbers of steps in trajectories:" + write (iout,'(8i10)') (nstep(i),i=0,ntraj) + write (iout,*) ii," conformations read from file",& + nazwa(:ilen(nazwa)) + write (iout,*) mm(islice)," conformations read so far, slice",& + islice + write (iout,*) ll(islice)," conformations stored so far, slice",& + islice + call flush(iout) + return + end subroutine xread +!-------------------------------------------------------------------------------- +! enecalc1.F +!-------------------------------------------------------------------------------- + subroutine write_dbase(islice,*) + + use geometry_data + use control_data, only:indpdb + use w_compar_data + use conform_compar, only:conf_compar +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! include "DIMENSIONS.COMPAR" + use geometry, only:int_from_cart1 +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif +! include "COMMON.CONTROL" +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.FFIELD" +! include "COMMON.ENEPS" +! include "COMMON.LOCAL" +! include "COMMON.WEIGHTS" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.COMPAR" +! include "COMMON.PROT" +! include "COMMON.CONTACTS1" + character(len=64) :: nazwa + character(len=80) :: bxname,cxname + character(len=64) :: bprotfile_temp + character(len=3) :: liczba,licz + character(len=2) :: licz2 + integer :: i,itj,ii,iii,j,k,l + integer :: ixdrf,iret + integer :: iscor,islice + real(kind=8) :: rmsdev,efree,eini + real(kind=4) :: csingle(3,nres*2) + real(kind=8) :: energ +! integer ilen,iroof +! external ilen,iroof + integer :: ir,ib,iparm + integer :: isecstr(nres) + write (licz2,'(bz,i2.2)') islice + call opentmp(islice,ientout,bprotfile_temp) + write (iout,*) "bprotfile_temp ",bprotfile_temp + call flush(iout) + if (.not.bxfile .and. .not. cxfile .and. indpdb.eq.0 & + .and. ensembles.eq.0) then + close(ientout,status="delete") + return + endif +#ifdef MPI + write (liczba,'(bz,i3.3)') me + if (bxfile .or. cxfile .or. ensembles.gt.0) then + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//liczba//".bx" + else + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//liczba//"_par"//licz//".bx" + endif + open (ientin,file=bxname,status="unknown",& + form="unformatted",access="direct",recl=lenrec1) + endif +#else + if (bxfile .or. cxfile .or. ensembles.gt.0) then + if (nslice.eq.1) then + bxname = prefix(:ilen(prefix))//".bx" + else + bxname = prefix(:ilen(prefix))// & + "_slice_"//licz2//".bx" + endif + open (ientin,file=bxname,status="unknown",& + form="unformatted",access="direct",recl=lenrec1) + write (iout,*) "Calculating energies; writing geometry",& + " and energy components to ",bxname(:ilen(bxname)) + endif +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,cxname, "w", iret) +#else + call xdrfopen(ixdrf,cxname, "w", iret) +#endif + if (iret.eq.0) then + write (iout,*) "Error opening cxfile ",cxname(:ilen(cxname)) + cxfile=.false. + endif +!el endif +#endif + if (indpdb.gt.0) then + if (nslice.eq.1) then +#ifdef MPI + if (.not.separate_parset) then + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot)) & + //liczba//'.stat' + else + write (licz,'(bz,i3.3)') myparm + statname=prefix(:ilen(prefix))//'_par'//licz//'_'// & + pot(:ilen(pot))//liczba//'.stat' + endif + +#else + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))//'.stat' +#endif + else +#ifdef MPI + if (.not.separate_parset) then + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))// & + "_slice_"//licz2//liczba//'.stat' + else + write (licz,'(bz,i3.3)') myparm + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))// & + '_par'//licz//"_slice_"//licz2//liczba//'.stat' + endif +#else + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot)) & + //"_slice_"//licz2//'.stat' +#endif + endif + open(istat,file=statname,status="unknown") + endif + +#ifdef MPI + do i=1,scount(me) +#else + do i=1,ntot(islice) +#endif + read(ientout,rec=i,err=101) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,(q(k,i),k=1,nQ),iR,ib,iparm +! write (iout,*) iR,ib,iparm,eini,efree + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + call int_from_cart1(.false.) + iscore=0 +! write (iout,*) "Calling conf_compar",i +! call flush(iout) + anatemp= 1.0d0/(beta_h(ib,iparm)*1.987D-3) + if (indpdb.gt.0) then + call conf_compar(i,.false.,.true.) +! else +! call elecont(.false.,ncont,icont,nnt,nct) +! call secondary2(.false.,.false.,ncont,icont,isecstr) + endif +! write (iout,*) "Exit conf_compar",i +! call flush(iout) + if (bxfile .or.cxfile .or. ensembles.gt.0) write (ientin,rec=i) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& +! & potE(i,iparm),-entfac(i),rms_nat,iscore + potE(i,nparmset),-entfac(i),rms_nat,iscore +! write (iout,'(2i5,3e15.5)') i,me,potE(i,iparm),-entfac(i) +#ifndef MPI + if (cxfile) call cxwrite(ixdrf,csingle,potE(i,nparmset),& + -entfac(i),rms_nat,iscore) +#endif + enddo + close(ientout,status="delete") + close(istat) + if (bxfile .or. cxfile .or. ensembles.gt.0) close(ientin) +#ifdef MPI + call MPI_Barrier(WHAM_COMM,IERROR) + if (me.ne.Master .or. .not.bxfile .and. .not. cxfile & + .and. ensembles.eq.0) return + write (iout,*) + if (bxfile .or. ensembles.gt.0) then + if (nslice.eq.1) then + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//".bx" + else + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"_par"//licz//".bx" + endif + else + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//"_slice_"//licz2//".bx" + else + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"par_"//licz// & + "_slice_"//licz2//".bx" + endif + endif + open (ientout,file=bxname,status="unknown",& + form="unformatted",access="direct",recl=lenrec1) + write (iout,*) "Master is creating binary database ",& + bxname(:ilen(bxname)) + endif + if (cxfile) then + if (nslice.eq.1) then + if (.not.separate_parset) then + cxname = prefix(:ilen(prefix))//".cx" + else + cxname = prefix(:ilen(prefix))//"_par"//licz//".cx" + endif + else + if (.not.separate_parset) then + cxname = prefix(:ilen(prefix))// & + "_slice_"//licz2//".cx" + else + cxname = prefix(:ilen(prefix))//"_par"//licz// & + "_slice_"//licz2//".cx" + endif + endif +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,cxname, "w", iret) +#else + call xdrfopen(ixdrf,cxname, "w", iret) +#endif + if (iret.eq.0) then + write (iout,*) "Error opening cxfile ",cxname(:ilen(cxname)) + cxfile=.false. + endif + endif + do j=0,nprocs-1 + write (liczba,'(bz,i3.3)') j + if (separate_parset) then + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//liczba//"_par"//licz//".bx" + else + bxname = prefix(:ilen(prefix))//liczba//".bx" + endif + open (ientin,file=bxname,status="unknown",& + form="unformatted",access="direct",recl=lenrec1) + write (iout,*) "Master is reading conformations from ",& + bxname(:ilen(bxname)) + iii = 0 +! write (iout,*) "j",j," indstart",indstart(j)," indend",indend(j) +! call flush(iout) + do i=indstart(j),indend(j) + iii = iii+1 + read(ientin,rec=iii,err=101) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,iscor + if (bxfile .or. ensembles.gt.0) then + write (ientout,rec=i) & + ((csingle(l,k),l=1,3),k=1,nres),& + ((csingle(l,k+nres),l=1,3),k=nnt,nct),& + nss,(ihpb(k),jhpb(k),k=1,nss),& + eini,efree,rmsdev,iscor + endif + if(cxfile)call cxwrite(ixdrf,csingle,eini,efree,rmsdev,iscor) +#ifdef DEBUG + do k=1,2*nres + do l=1,3 + c(l,k)=csingle(l,k) + enddo + enddo + call int_from_cart1(.false.) + write (iout,'(2i5,3e15.5)') i,iii,eini,efree + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(f10.5,i5)') rmsdev,iscor +#endif + enddo ! i + write (iout,*) iii," conformations (from",indstart(j)," to",& + indend(j),") read from ",& + bxname(:ilen(bxname)) + close (ientin,status="delete") + enddo ! j + if (bxfile .or. cxfile .or. ensembles.gt.0) close (ientout) +#if (defined(AIX) && !defined(JUBL)) + if (cxfile) call xdrfclose_(ixdrf,cxname,iret) +#else + if (cxfile) call xdrfclose(ixdrf,cxname,iret) +#endif +#endif + return + 101 write (iout,*) "Error in scratchfile." + call flush(iout) + return 1 + end subroutine write_dbase +!------------------------------------------------------------------------------- + subroutine cxwrite(ixdrf,csingle,eini,efree,rmsdev,iscor) +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! include "DIMENSIONS.COMPAR" +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif +! include "COMMON.CONTROL" +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.FFIELD" +! include "COMMON.ENEPS" +! include "COMMON.LOCAL" +! include "COMMON.WEIGHTS" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.COMPAR" +! include "COMMON.PROT" + integer :: i,j,itmp,iscor,iret,ixdrf + real(kind=8) :: rmsdev,efree,eini + real(kind=4) :: csingle(3,nres*2),xoord(3,2*nres+2) + real(kind=4) :: prec + +! write (iout,*) "cxwrite" +! call flush(iout) + prec=10000.0 + do i=1,nres + do j=1,3 + xoord(j,i)=csingle(j,i) + enddo + enddo + do i=nnt,nct + do j=1,3 + xoord(j,nres+i-nnt+1)=csingle(j,i+nres) + enddo + enddo + + itmp=nres+nct-nnt+1 + +! write (iout,*) "itmp",itmp +! call flush(iout) +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) + +! write (iout,*) "xdrf3dfcoord" +! call flush(iout) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + enddo + call xdrffloat_(ixdrf,real(eini),iret) + call xdrffloat_(ixdrf,real(efree),iret) + call xdrffloat_(ixdrf,real(rmsdev),iret) + call xdrfint_(ixdrf,iscor,iret) +#else + call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) + + call xdrfint(ixdrf, nss, iret) + do j=1,nss + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + enddo + call xdrffloat(ixdrf,real(eini),iret) + call xdrffloat(ixdrf,real(efree),iret) + call xdrffloat(ixdrf,real(rmsdev),iret) + call xdrfint(ixdrf,iscor,iret) +#endif + + return + end subroutine cxwrite +!------------------------------------------------------------------------------- +! slices.F +!------------------------------------------------------------------------------- + subroutine set_slices(is,ie,ts,te,iR,ib,iparm) +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.PROTFILES' +! include 'COMMON.OBCINKA' +! include 'COMMON.PROT' + integer :: islice,iR,ib,iparm + integer :: is(MaxSlice),ie(MaxSlice),nrec_slice + real(kind=8) :: ts(MaxSlice),te(MaxSlice),time_slice + + do islice=1,nslice + if (time_end_collect(iR,ib,iparm).ge.1.0d10) then + ts(islice)=time_start_collect(iR,ib,iparm) + te(islice)=time_end_collect(iR,ib,iparm) + nrec_slice=(rec_end(iR,ib,iparm)- & + rec_start(iR,ib,iparm)+1)/nslice + is(islice)=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice + ie(islice)=rec_start(iR,ib,iparm)+islice*nrec_slice-1 + else + time_slice=(time_end_collect(iR,ib,iparm) & + -time_start_collect(iR,ib,iparm))/nslice + ts(islice)=time_start_collect(iR,ib,iparm)+(islice-1)* & + time_slice + te(islice)=time_start_collect(iR,ib,iparm)+islice*time_slice + is(islice)=rec_start(iR,ib,iparm) + ie(islice)=rec_end(iR,ib,iparm) + endif + enddo + + write (iout,*) "nrec_slice",nrec_slice," time_slice",time_slice + write (iout,*) "is",(is(islice),islice=1,nslice) + write (iout,*) "ie",(ie(islice),islice=1,nslice) + write (iout,*) "rec_start",& + rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) + write (iout,*) "ts",(ts(islice),islice=1,nslice) + write (iout,*) "te",(te(islice),islice=1,nslice) + write (iout,*) "time_start",& + time_start_collect(iR,ib,iparm)," time_end",& + time_end_collect(iR,ib,iparm) + call flush(iout) + + return + end subroutine set_slices +!----------------------------------------------------------------------------- + integer function slice(irecord,time,is,ie,ts,te) +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.PROTFILES' +! include 'COMMON.OBCINKA' +! include 'COMMON.PROT' + integer :: is(MaxSlice),ie(MaxSlice),nrec_slice + real(kind=8) :: ts(MaxSlice),te(MaxSlice),time_slice + integer :: i,ii,irecord + real(kind=8) :: time + +! write (iout,*) "within slice nslice",nslice +! call flush(iout) + if (irecord.lt.is(1) .or. time.lt.ts(1)) then + ii=0 + else + ii=1 + do while (ii.le.nslice .and. & + (irecord.lt.is(ii) .or. irecord.gt.ie(ii) .or. & + time.lt.ts(ii) .or. time.gt.te(ii)) ) +! write (iout,*) "ii",ii,time,ts(ii) +! call flush(iout) + ii=ii+1 + enddo + endif +! write (iout,*) "end: ii",ii +! call flush(iout) + slice=ii + return + end function slice +!----------------------------------------------------------------------------- +! enecalc1.F +!----------------------------------------------------------------------------- + logical function conf_check(ii,iprint) + + use names, only:ntyp1 + use geometry_data + use energy_data, only:itype,dsc + use geometry, only:int_from_cart1 +! use +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +!#ifdef MPI +! use MPI_data +! include "mpif.h" +! include "COMMON.MPI" +!#endif +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.VAR" +! include "COMMON.SBRIDGE" +! include "COMMON.GEO" +! include "COMMON.FFIELD" +! include "COMMON.ENEPS" +! include "COMMON.LOCAL" +! include "COMMON.WEIGHTS" +! include "COMMON.INTERACT" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.CONTROL" +! include "COMMON.TORCNSTR" +! implicit none +#ifdef MPI + include "mpif.h" + integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) +#endif + integer :: j,k,l,ii,itj,iprint + if (.not. check_conf) then + conf_check=.true. + return + endif + call int_from_cart1(.false.) + do j=nnt+1,nct + if (itype(j-1).ne.ntyp1 .and. itype(j).ne.ntyp1 .and. & + (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0)) then + if (iprint.gt.0) & + write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),& + " for conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) & + "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + enddo + do j=nnt,nct + itj=itype(j) + if (itype(j).ne.10 .and.itype(j).ne.ntyp1 .and. & + (vbld(nres+j)-dsc(iabs(itj))).gt.2.0d0) then + if (iprint.gt.0) & + write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j),& + " for conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) & + "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + enddo + do j=3,nres + if (theta(j).le.0.0d0) then + if (iprint.gt.0) & + write (iout,*) "Zero theta angle(s) in conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) & + "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad + enddo + conf_check=.true. +! write (iout,*) "conf_check passed",ii + return + end function conf_check +!----------------------------------------------------------------------------- + end module io_database diff --git a/source/wham/io_database.f90 b/source/wham/io_database.f90 deleted file mode 100644 index 13d4f37..0000000 --- a/source/wham/io_database.f90 +++ /dev/null @@ -1,1488 +0,0 @@ - module io_database -!----------------------------------------------------------------------------- - use names - use wham_data - use io_units - use io_base, only:ilen - use energy_data, only:nnt,nct,nss,ihpb,jhpb,iset - use geometry_data, only:nres,c -#ifdef MPI - use MPI_data -! include "COMMON.MPI" -#endif - - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! readrtns.F -!------------------------------------------------------------------------------- - subroutine opentmp(islice,iunit,bprotfile_temp) -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! use MPI_data, only:me -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.PROT" -! include "COMMON.FREE" - character(len=64) :: bprotfile_temp - character(len=3) :: liczba,liczba2 - character(len=2) :: liczba1 - integer :: iunit,islice -! integer ilen,iroof -! external ilen,iroof -! logical :: lerr -! integer :: lenrec,lenrec2 - -!el -! lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ -! lenrec=lenrec2+8 - write (liczba1,'(bz,i2.2)') islice -#ifdef MPI - write (liczba,'(bz,i3.3)') me -!#ifdef MPI -! write (iout,*) "separate_parset ",separate_parset, -! & " myparm",myparm - if (separate_parset) then - write (liczba2,'(bz,i3.3)') myparm - bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & - prefix(:ilen(prefix))//liczba//"_"//liczba2//".xbin.tmp"//liczba1 - open (iunit,file=bprotfile_temp,status="unknown",& - form="unformatted",access="direct",recl=lenrec) - else - bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & - prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 - open (iunit,file=bprotfile_temp,status="unknown",& - form="unformatted",access="direct",recl=lenrec) - endif -#else - bprotfile_temp = scratchdir(:ilen(scratchdir))// & - "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 - open (iunit,file=bprotfile_temp,status="unknown",& - form="unformatted",access="direct",recl=lenrec) -#endif -! write (iout,*) "OpenTmp iunit",iunit," bprotfile_temp", -! & bprotfile_temp -! call flush(iout) - return - end subroutine opentmp -!------------------------------------------------------------------------------- - subroutine read_database(*) - -! use energy_data, only:nct,nnt,nss -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" - use MPI_data, only:me,nprocs -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.GEO" -! include "COMMON.ENEPS" -! include "COMMON.PROT" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.SBRIDGE" -! include "COMMON.OBCINKA" - real(kind=4) :: csingle(3,nres*2) !(3,maxres2) - character(len=64) :: nazwa,bprotfile_temp - character(len=3) :: liczba - character(len=2) :: liczba1 - integer :: i,j,ii,jj(nslice),k,kk(nslice),l,& - ll(nslice),mm(nslice),if - integer :: nrec,nlines,iscor,iunit,islice - real(kind=8) :: energ -! integer ilen,iroof -! external ilen,iroof - real(kind=8) :: rmsdev,energia(0:n_ene),efree,eini,temp -!el real(kind=8) :: rmsdev,energia(0:max_eneW),efree,eini,temp - real(kind=8) :: prop(nQ) !(maxQ) - integer :: ntot_all(nslice,0:nprocs-1)!(maxslice,0:maxprocs-1) - integer :: iparm,ib,iib,ir,nprop,nthr,npars - real(kind=8) :: etot,time - integer :: ixdrf,iret - logical :: lerr,linit - - lenrec1=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 - lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ - lenrec=lenrec2+8 - write (iout,*) "lenrec",lenrec," lenrec1",lenrec1,& - " lenrec2",lenrec2 - - do i=1,nQ - prop(i)=0.0d0 - enddo - do islice=1,nslice - ll(islice)=0 - mm(islice)=0 - enddo - write (iout,*) "nparmset",nparmset - if (hamil_rep) then - npars=1 - else - npars=nparmset - endif - do iparm=1,npars - - if (replica(iparm)) then - nthr = 1 - else - nthr = nT_h(iparm) - endif - - do ib=1,nthr - do iR=1,nRR(ib,iparm) - - write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ - do islice=1,nslice - jj(islice)=0 - kk(islice)=0 - enddo - - IF (NFILE_BIN(iR,ib,iparm).GT.0) THEN -! Read conformations from binary DA files (one per batch) and write them to -! a binary DA scratchfile. - write (liczba,'(bz,i3.3)') me - do if=1,nfile_bin(iR,ib,iparm) - nazwa=protfiles(if,1,iR,ib,iparm) & - (:ilen(protfiles(if,1,iR,ib,iparm)))//".bx" - open (ientin,file=nazwa,status="old",form="unformatted",& - access="direct",recl=lenrec2,err=1111) - ii=0 - do islice=1,nslice - call opentmp(islice,ientout,bprotfile_temp) - call bxread(nazwa,islice,ii,jj(islice),kk(islice),ll(islice),& - mm(islice),iR,ib,iparm) - close(ientout) - enddo - close(ientin) - enddo - ENDIF ! NFILE_BIN>0 -! - IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN -! Read conformations from multiple ASCII int files and write them to a binary -! DA scratchfile. - do if=1,nfile_asc(iR,ib,iparm) - nazwa=protfiles(if,2,iR,ib,iparm) & - (:ilen(protfiles(if,2,iR,ib,iparm)))//".x" - open(unit=ientin,file=nazwa,status='old',err=1111) - write(iout,*) "reading ",nazwa(:ilen(nazwa)) - ii=0 - call xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) - enddo ! if - ENDIF - IF (NFILE_CX(iR,ib,iparm).gt.0) THEN -! Read conformations from cx files and write them to a binary -! DA scratchfile. - do if=1,nfile_cx(iR,ib,iparm) - nazwa=protfiles(if,2,iR,ib,iparm) & - (:ilen(protfiles(if,2,iR,ib,iparm)))//".cx" - write(iout,*) "reading ",nazwa(:ilen(nazwa)) - ii=0 - print *,"Calling cxread" - call cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,& - *1111) -write(iout,*)"after call cxread" - close(ientout) - write (iout,*) "exit cxread" - call flush(iout) - enddo - ENDIF -write(iout,*)"*********************in read database" - - do islice=1,nslice -! stot(islice)=0 - stot(islice)=stot(islice)+jj(islice) - enddo - - enddo - enddo - write (iout,*) "IPARM",iparm - enddo - - if (nslice.eq.1) then -#ifdef MPI - write (liczba,'(bz,i3.3)') me - bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & - prefix(:ilen(prefix))//liczba//".xbin.tmp" -#else - bprotfile_temp = scratchdir(:ilen(scratchdir))// & - "/"//prefix(:ilen(prefix))//".xbin.tmp" -#endif - write(iout,*) mm(1)," conformations read",ll(1),& - " conformations written to ",& - bprotfile_temp(:ilen(bprotfile_temp)) - else - do islice=1,nslice - write (liczba1,'(bz,i2.2)') islice -#ifdef MPI - write (liczba,'(bz,i3.3)') me - bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & - prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 -#else - bprotfile_temp = scratchdir(:ilen(scratchdir))// & - "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 -#endif - write(iout,*) mm(islice)," conformations read",ll(islice),& - " conformations written to ",& - bprotfile_temp(:ilen(bprotfile_temp)) - enddo - endif - -#ifdef MPI -! Check if everyone has the same number of conformations - call MPI_Allgather(stot(1),nslice,MPI_INTEGER,& - ntot_all(1,0),nslice,MPI_INTEGER,MPI_Comm_World,IERROR) - lerr=.false. - do i=0,nprocs-1 - if (i.ne.me) then - do islice=1,nslice - if (stot(islice).ne.ntot_all(islice,i)) then - write (iout,*) "Number of conformations at processor",i,& - " differs from that at processor",me,& - stot(islice),ntot_all(islice,i)," slice",islice - lerr = .true. - endif - enddo - endif - enddo - if (lerr) then - write (iout,*) - write (iout,*) "Numbers of conformations read by processors" - write (iout,*) - do i=0,nprocs-1 - write (iout,'(8i10)') i,(ntot_all(islice,i),islice=1,nslice) - enddo - write (iout,*) "Calculation terminated." - call flush(iout) - return 1 - endif - do islice=1,nslice - ntot(islice)=stot(islice) - enddo -write(iout,*) "end of read database" - return -#endif - 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) - call flush(iout) - return 1 - end subroutine read_database -!-------------------------------------------------------------------------------- - integer function iroof(n,m) - integer :: n,m,ii - ii = n/m - if (ii*m .lt. n) ii=ii+1 - iroof = ii - return - end function iroof -!-------------------------------------------------------------------------------- -! bxread.F -!-------------------------------------------------------------------------------- - subroutine bxread(nazwa,islice,ii,jj,kk,ll,mm,iR,ib,iparm) -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! use energy_data, only:nnt,nct,nss,ihpb,jhpbi - use MPI_data, only:nprocs -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.GEO" -! include "COMMON.ENEPS" -! include "COMMON.PROT" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.SBRIDGE" - real(kind=4) :: csingle(3,nres*2) !(3,maxres2) - character(len=64) :: nazwa,bprotfile_temp - character(len=3) :: liczba - integer :: i,is,ie,j,ii,jj,k,kk,l,ll,mm,if - integer :: nrec,nlines,iscor,islice - real(kind=8) :: energ -! integer ilen,iroof -! external ilen,iroof - real(kind=8) :: rmsdev,energia(0:n_ene),efree,eini,temp -!el real(kind=8) :: rmsdev,energia(0:max_eneW),efree,eini,temp - real(kind=8) :: prop(nQ) !(maxQ) - integer :: ntot_all(0:nprocs-1)!(0:maxprocs-1) - integer :: iparm,ib,iib,ir,nprop,nthr,nrec_slice - real(kind=8) :: etot,time - logical :: lerr - nrec_slice=(rec_end(iR,ib,iparm)-rec_start(iR,ib,iparm)+1)/nslice - is=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice - ie=rec_start(iR,ib,iparm)+islice*nrec_slice-1 - write (iout,*) "bxread: islice",islice," nslice",nslice,& - " nrec_slice",nrec_slice - write (iout,*) "is",is," ie",ie,"rec_start",& - rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) - do i=is,ie - read(ientin,rec=i+1,err=101) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,(prop(j),j=1,nQ),iscor - ii=ii+1 - kk=kk+1 - if (mod(kk,isampl(iparm)).eq.0) then - jj=jj+1 - write(ientout,rec=jj) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,(prop(j),j=1,nQ),iR,ib,iparm -#ifdef DEBUG - do i=1,2*nres - do j=1,3 - c(j,i)=csingle(j,i) - enddo - enddo - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",jj - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) - write (iout,'(f10.5,i5)') rmsdev,iscor -#endif - endif - enddo - 101 continue - close(ientin) - write (iout,*) ii," conformations read from DA file ",& - nazwa(:ilen(nazwa)) - write (iout,*) kk," conformations read so far, slice",islice - write (iout,*) jj," conformations stored so far, slice",islice - - return - end subroutine bxread -!-------------------------------------------------------------------------------- -! cxread.F -!-------------------------------------------------------------------------------- - subroutine cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,*) - -#define DEBUG -#ifdef DEBUG - use geometry, only:int_from_cart1 - use geometry_data, only:vbld,rad2deg,theta,phi,alph,omeg - integer :: iscor -#endif -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.FREE' - integer,parameter :: MaxTraj=2050 -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' -! include 'COMMON.PROTFILES' -! include 'COMMON.OBCINKA' -! include 'COMMON.FREE' -! include 'COMMON.VAR' -! include 'COMMON.GEO' -! include 'COMMON.PROT' - character(len=64) :: nazwa,bprotfile_temp - real(kind=4) :: rtime,rpotE,ruconst,rt_bath,rprop(nQ) !(2000) !(maxQ) - real(kind=8) :: time - integer :: iret,itmp,itraj,ntraj - real(kind=4) :: xoord(3,2*nres+2),prec - integer :: nstep(0:MaxTraj-1) -! integer ilen -! external ilen - integer :: ii,jj(nslice),kk(nslice),ll(nslice),mm(nslice) !(maxslice) - integer :: is(nSlice),ie(nSlice),nrec_slice - real(kind=8) :: ts(nSlice),te(nSlice),time_slice - integer :: iR,ib,iparm,i,j,it,islice,nprop_prev - integer :: k,l,iib,islice1,nprop - real(kind=8) :: efree,rmsdev - integer :: ixdrf -!el integer :: slice -! logical :: conf_check -! ixdrf=0 -! nprop=0 - -! ruconst=0.0d0 -! rtime=0.0d0 -! rpotE=0.0d0 -! rt_bath=0.0d0 - - call set_slices(is,ie,ts,te,iR,ib,iparm) - nprop_prev=0 - do i=1,nQ - rprop(i)=0.0d0 - enddo - do i=0,MaxTraj-1 - nstep(i)=0 - enddo - ntraj=0 - it=0 - iret=1 -#if (defined(AIX) && !defined(JUBL)) - call xdrfopen_(ixdrf,nazwa, "r", iret) -#else - call xdrfopen(ixdrf,nazwa, "r", iret) -#endif - if (iret.eq.0) return 1 - - islice1=1 - call opentmp(islice1,ientout,bprotfile_temp) - print *,"bumbum" !d - do while (iret.gt.0) - -#if (defined(AIX) && !defined(JUBL)) - call xdrffloat_(ixdrf, rtime, iret) - print *,"rtime",rtime," iret",iret !d - call xdrffloat_(ixdrf, rpotE, iret) - write (iout,*) "rpotE",rpotE," iret",iret !d - call flush(iout) - call xdrffloat_(ixdrf, ruconst, iret) - call xdrffloat_(ixdrf, rt_bath, iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrfint_(ixdrf, nprop, iret) - if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) & - call xdrfint(ixdrf, iset, iret) - do i=1,nprop - call xdrffloat_(ixdrf, rprop(i), iret) - enddo -#else - call xdrffloat(ixdrf, rtime, iret) - call xdrffloat(ixdrf, rpotE, iret) - write (iout,*) "rpotE",rpotE," iret",iret !d - call flush(iout) - call xdrffloat(ixdrf, ruconst, iret) - call xdrffloat(ixdrf, rt_bath, iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrfint(ixdrf, nprop, iret) - write (iout,*) "nprop",nprop !d - if (it.gt.0 .and. nprop.ne.nprop_prev) then - write (iout,*) "Warning previous nprop",nprop_prev,& - " current",nprop - nprop=nprop_prev - else - nprop_prev=nprop - endif - call flush(iout) - if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) & - call xdrfint(ixdrf, iset, iret) - do i=1,nprop - call xdrffloat(ixdrf, rprop(i), iret) - enddo -#endif - if (iret.eq.0) exit - itraj=mod(it,totraj(iR,iparm)) -#define DEBUG -#ifdef DEBUG - write (iout,*) "ii",ii," itraj",itraj," it",it -#endif - if (iset.eq.0) iset = 1 - call flush(iout) - it=it+1 - if (itraj.gt.ntraj) ntraj=itraj - nstep(itraj)=nstep(itraj)+1 -! rprop(2)=dsqrt(rprop(2)) -! rprop(3)=dsqrt(rprop(3)) -#ifdef DEBUG - write (iout,*) "umbrella ",umbrella - write (iout,*) rtime,rpotE,rt_bath,nss,& - (ihpb(j),jhpb(j),j=1,nss),(rprop(j),j=1,nprop) - write (iout,*) "nprop",nprop," iset",iset," myparm",myparm - call flush(iout) -#endif - prec=10000.0 - itmp=0 -#if (defined(AIX) && !defined(JUBL)) - call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) -#else - call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) -#endif -#ifdef DEBUG - write (iout,'(10f8.3)') ((xoord(j,i),j=1,3),i=1,2*nres+2) -#endif -#undef DEBUG - if (iret.eq.0) exit - if (itmp .ne. nres + nct - nnt + 1) then - write (iout,*) "Error: inconsistent sizes",itmp,nres+nct-nnt+1 - call flush(iout) - exit - endif - - time=rtime - write (iout,*) "calling slice" !d - call flush(iout) !d - islice=slice(nstep(itraj),time,is,ie,ts,te) - write (iout,*) "islice",islice !d - call flush(iout) !d - - do i=1,nres - do j=1,3 - c(j,i)=xoord(j,i) - enddo - enddo - do i=1,nct-nnt+1 - do j=1,3 - c(j,i+nres+nnt-1)=xoord(j,i+nres) - enddo - enddo - - if (islice.gt.0 .and. islice.le.nslice .and. (.not.separate_parset & - .or. iset.eq.myparm)) then - ii=ii+1 - kk(islice)=kk(islice)+1 - mm(islice)=mm(islice)+1 - if (mod(nstep(itraj),isampl(iparm)).eq.0 .and. & - conf_check(ll(islice)+1,1)) then - if (replica(iparm)) then - rt_bath=1.0d0/(rt_bath*1.987D-3) - do i=1,nT_h(iparm) - if (abs(real(beta_h(i,iparm))-rt_bath).lt.1.0e-4) then - iib = i - goto 22 - endif - enddo - 22 continue - if (i.gt.nT_h(iparm)) then - write (iout,*) "Error - temperature of conformation",& - ii,1.0d0/(rt_bath*1.987D-3),& - " does not match any of the list" - write (iout,*) & - 1.0d0/(rt_bath*1.987D-3),& - (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) - call flush(iout) -! exit -! call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) - ii=ii-1 - kk(islice)=kk(islice)-1 - mm(islice)=mm(islice)-1 - goto 112 - endif - else - iib = ib - endif - - efree=0.0d0 - jj(islice)=jj(islice)+1 - if (umbrella(iparm)) then - snk(iset,iib,iparm,islice)=snk(iset,iib,iparm,islice)+1 - else if (hamil_rep) then - snk(1,iib,iparm,islice)=snk(1,iib,iparm,islice)+1 - else - snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 - endif - ll(islice)=ll(islice)+1 -#ifdef DEBUG - write (iout,*) "Writing conformation, record",ll(islice) - write (iout,*) "ib",ib," iib",iib - write (iout,*) "ntraj",ntraj," itraj",itraj,& - " nstep",nstep(itraj) - write (iout,*) "pote",rpotE," time",rtime -! if (replica(iparm)) then -! write (iout,*) "TEMP",1.0d0/(rt_bath*1.987D-3) -! write (iout,*) "TEMP list" -! write (iout,*) -! & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) -! endif - write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ -! write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss -! write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 - call flush(iout) -#endif - if (islice.ne.islice1) then -! write (iout,*) "islice",islice," islice1",islice1 - close(ientout) -! write (iout,*) "Closing file ", -! & bprotfile_temp(:ilen(bprotfile_temp)) - call opentmp(islice,ientout,bprotfile_temp) -! write (iout,*) "Opening file ", -! & bprotfile_temp(:ilen(bprotfile_temp)) - islice1=islice - endif - if (umbrella(iparm)) then - write(ientout,rec=ll(islice)) & - ((xoord(l,k),l=1,3),k=1,nres),& - ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ),& - iset,iib,iparm - else if (hamil_rep) then - write(ientout,rec=ll(islice)) & - ((xoord(l,k),l=1,3),k=1,nres),& - ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ),& - iR,iib,iset - else - write(ientout,rec=ll(islice)) & - ((xoord(l,k),l=1,3),k=1,nres),& - ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ),& - iR,iib,iparm - endif -#ifdef DEBUG - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",ll(islice) - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) -! write (iout,'(8f10.5)') (rprop(j),j=1,nQ) - write (iout,'(16i5)') iscor - call flush(iout) -#endif - endif - endif - - 112 continue - - enddo - close(ientout) -#if (defined(AIX) && !defined(JUBL)) - call xdrfclose_(ixdrf, iret) -#else - call xdrfclose(ixdrf, iret) -#endif - write (iout,'(i10," trajectories found in file.")') ntraj+1 - write (iout,'(a)') "Numbers of steps in trajectories:" - write (iout,'(8i10)') (nstep(i),i=0,ntraj) - write (iout,*) ii," conformations read from file",& - nazwa(:ilen(nazwa)) - do islice=1,nslice - write (iout,*) mm(islice)," conformations read so far, slice",& - islice - write (iout,*) ll(islice),& - " conformations stored so far, slice",islice - enddo - call flush(iout) -#undef DEBUG - return - end subroutine cxread -!-------------------------------------------------------------------------------- -! xread.F -!-------------------------------------------------------------------------------- - subroutine xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) - - use geometry_data -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" - use MPI_data, only:nprocs -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif - integer,parameter :: MaxTraj=2050 -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.GEO" -! include "COMMON.ENEPS" -! include "COMMON.PROT" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.SBRIDGE" -! include "COMMON.OBCINKA" - real(kind=4) :: csingle(3,nres*2) - character(len=64) :: nazwa,bprotfile_temp - integer :: i,j,k,l,ii,jj(nslice),kk(nslice),ll(nslice),& - mm(nslice) !(maxslice) - integer :: iscor,islice,islice1 !el,slice - real(kind=8) :: energ -! integer ilen,iroof -! external ilen,iroof - real(kind=8) :: rmsdev,energia(0:n_ene),efree,eini,temp -!el real(kind=8) :: rmsdev,energia(0:max_eneW),efree,eini,temp - real(kind=8) :: prop(nQ) !(maxQ) - integer :: ntot_all(0:nprocs-1)!(0:maxprocs-1) - integer :: iparm,ib,iib,ir,nprop,nthr - real(kind=8) :: etot,time,ts(nslice),te(nslice) - integer :: is(nslice),ie(nslice),itraj,ntraj,it,iset - integer :: nstep(0:MaxTraj-1) - logical :: lerr - - call set_slices(is,ie,ts,te,iR,ib,iparm) - do i=1,nQ - prop(i)=0.0d0 - enddo - do i=0,MaxTraj-1 - nstep(i)=0 - enddo - ntraj=0 - it=0 - islice1=1 - call opentmp(islice1,ientout,bprotfile_temp) - do while (.true.) - if (replica(iparm)) then - if (hamil_rep .or. umbrella(iparm)) then - read (ientin,*,end=1112,err=1112) time,eini,& - etot,temp,nss,(ihpb(j),jhpb(j),j=1,nss),& - nprop,(prop(j),j=1,nprop),iset - else - read (ientin,*,end=1112,err=1112) time,eini,& - etot,temp,nss,(ihpb(j),jhpb(j),j=1,nss),& - nprop,(prop(j),j=1,nprop) - endif - temp=1.0d0/(temp*1.987D-3) -! write (iout,*) time,eini,etot,nss, -! & (ihpb(j),jhpb(j),j=1,nss),(prop(j),j=1,nprop) -! call flush(iout) - do i=1,nT_h(iparm) - if (beta_h(i,iparm).eq.temp) then - iib = i - goto 22 - endif - enddo - 22 continue - if (i.gt.nT_h(iparm)) then - write (iout,*) "Error - temperature of conformation",& - ii,1.0d0/(temp*1.987D-3),& - " does not match any of the list" - write (iout,*) & - 1.0d0/(temp*1.987D-3),& - (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - endif - else - read (ientin,*,end=1112,err=1112) time,eini,& - etot,nss,(ihpb(j),jhpb(j),j=1,nss),& - nprop,(prop(j),j=1,nprop) - iib = ib - endif - itraj=mod(it,totraj(iR,iparm)) -! write (*,*) "ii",ii," itraj",itraj -! call flush(iout) - it=it+1 - if (itraj.gt.ntraj) ntraj=itraj - nstep(itraj)=nstep(itraj)+1 - islice=slice(nstep(itraj),time,is,ie,ts,te) - read (ientin,'(8f10.5)',end=1112,err=1112) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct) - efree=0.0d0 - if (islice.gt.0 .and. islice.le.nslice) then - ii=ii+1 - kk(islice)=kk(islice)+1 - mm(islice)=mm(islice)+1 - if (mod(nstep(itraj),isampl(iparm)).eq.0) then - jj(islice)=jj(islice)+1 - if (hamil_rep) then - snk(iR,iib,iset,islice)=snk(iR,iib,iset,islice)+1 - else if (umbrella(iparm)) then - snk(iset,iib,iparm,islice)=snk(iset,iib,iparm,islice)+1 - else - snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 - endif - ll(islice)=ll(islice)+1 -! write (iout,*) ii,kk,jj,ll,eini,(prop(j),j=1,nprop) -#ifdef DEBUG -! write (iout,*) "Writing conformation, record",ll(islice) -! write (iout,*) "ib",ib," iib",iib - if (replica(iparm)) then - write (iout,*) "TEMP",1.0d0/(temp*1.987D-3) - write (iout,*) "TEMP list" - write (iout,*) & - (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) - endif - call flush(iout) -#endif -! write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ -! write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss -! write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 -! call flush(iout) - if (islice.ne.islice1) then -! write (iout,*) "islice",islice," islice1",islice1 - close(ientout) -! write (iout,*) "Closing file ", -! & bprotfile_temp(:ilen(bprotfile_temp)) - call opentmp(islice,ientout,bprotfile_temp) -! write (iout,*) "Opening file ", -! & bprotfile_temp(:ilen(bprotfile_temp)) -! call flush(iout) - islice1=islice - endif - write(ientout,rec=ll(islice)) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,(prop(i),i=1,nQ),iR,iib,iparm -#ifdef DEBUG - do i=1,2*nres - do j=1,3 - c(j,i)=csingle(j,i) - enddo - enddo - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",ll(islice) - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) -! write (iout,'(8f10.5)') (prop(j),j=1,nQ) - write (iout,'(16i5)') iscor - call flush(iout) -#endif - endif - endif - enddo - 1112 continue - close(ientout) - write (iout,'(i10," trajectories found in file.")') ntraj+1 - write (iout,'(a)') "Numbers of steps in trajectories:" - write (iout,'(8i10)') (nstep(i),i=0,ntraj) - write (iout,*) ii," conformations read from file",& - nazwa(:ilen(nazwa)) - write (iout,*) mm(islice)," conformations read so far, slice",& - islice - write (iout,*) ll(islice)," conformations stored so far, slice",& - islice - call flush(iout) - return - end subroutine xread -!-------------------------------------------------------------------------------- -! enecalc1.F -!-------------------------------------------------------------------------------- - subroutine write_dbase(islice,*) - - use geometry_data - use control_data, only:indpdb - use w_compar_data - use conform_compar, only:conf_compar -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! include "DIMENSIONS.COMPAR" - use geometry, only:int_from_cart1 -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif -! include "COMMON.CONTROL" -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.FFIELD" -! include "COMMON.ENEPS" -! include "COMMON.LOCAL" -! include "COMMON.WEIGHTS" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.COMPAR" -! include "COMMON.PROT" -! include "COMMON.CONTACTS1" - character(len=64) :: nazwa - character(len=80) :: bxname,cxname - character(len=64) :: bprotfile_temp - character(len=3) :: liczba,licz - character(len=2) :: licz2 - integer :: i,itj,ii,iii,j,k,l - integer :: ixdrf,iret - integer :: iscor,islice - real(kind=8) :: rmsdev,efree,eini - real(kind=4) :: csingle(3,nres*2) - real(kind=8) :: energ -! integer ilen,iroof -! external ilen,iroof - integer :: ir,ib,iparm - integer :: isecstr(nres) - write (licz2,'(bz,i2.2)') islice - call opentmp(islice,ientout,bprotfile_temp) - write (iout,*) "bprotfile_temp ",bprotfile_temp - call flush(iout) - if (.not.bxfile .and. .not. cxfile .and. indpdb.eq.0 & - .and. ensembles.eq.0) then - close(ientout,status="delete") - return - endif -#ifdef MPI - write (liczba,'(bz,i3.3)') me - if (bxfile .or. cxfile .or. ensembles.gt.0) then - if (.not.separate_parset) then - bxname = prefix(:ilen(prefix))//liczba//".bx" - else - write (licz,'(bz,i3.3)') myparm - bxname = prefix(:ilen(prefix))//liczba//"_par"//licz//".bx" - endif - open (ientin,file=bxname,status="unknown",& - form="unformatted",access="direct",recl=lenrec1) - endif -#else - if (bxfile .or. cxfile .or. ensembles.gt.0) then - if (nslice.eq.1) then - bxname = prefix(:ilen(prefix))//".bx" - else - bxname = prefix(:ilen(prefix))// & - "_slice_"//licz2//".bx" - endif - open (ientin,file=bxname,status="unknown",& - form="unformatted",access="direct",recl=lenrec1) - write (iout,*) "Calculating energies; writing geometry",& - " and energy components to ",bxname(:ilen(bxname)) - endif -#if (defined(AIX) && !defined(JUBL)) - call xdrfopen_(ixdrf,cxname, "w", iret) -#else - call xdrfopen(ixdrf,cxname, "w", iret) -#endif - if (iret.eq.0) then - write (iout,*) "Error opening cxfile ",cxname(:ilen(cxname)) - cxfile=.false. - endif -!el endif -#endif - if (indpdb.gt.0) then - if (nslice.eq.1) then -#ifdef MPI - if (.not.separate_parset) then - statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot)) & - //liczba//'.stat' - else - write (licz,'(bz,i3.3)') myparm - statname=prefix(:ilen(prefix))//'_par'//licz//'_'// & - pot(:ilen(pot))//liczba//'.stat' - endif - -#else - statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))//'.stat' -#endif - else -#ifdef MPI - if (.not.separate_parset) then - statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))// & - "_slice_"//licz2//liczba//'.stat' - else - write (licz,'(bz,i3.3)') myparm - statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))// & - '_par'//licz//"_slice_"//licz2//liczba//'.stat' - endif -#else - statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot)) & - //"_slice_"//licz2//'.stat' -#endif - endif - open(istat,file=statname,status="unknown") - endif - -#ifdef MPI - do i=1,scount(me) -#else - do i=1,ntot(islice) -#endif - read(ientout,rec=i,err=101) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,(q(k,i),k=1,nQ),iR,ib,iparm -! write (iout,*) iR,ib,iparm,eini,efree - do j=1,2*nres - do k=1,3 - c(k,j)=csingle(k,j) - enddo - enddo - call int_from_cart1(.false.) - iscore=0 -! write (iout,*) "Calling conf_compar",i -! call flush(iout) - anatemp= 1.0d0/(beta_h(ib,iparm)*1.987D-3) - if (indpdb.gt.0) then - call conf_compar(i,.false.,.true.) -! else -! call elecont(.false.,ncont,icont,nnt,nct) -! call secondary2(.false.,.false.,ncont,icont,isecstr) - endif -! write (iout,*) "Exit conf_compar",i -! call flush(iout) - if (bxfile .or.cxfile .or. ensembles.gt.0) write (ientin,rec=i) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& -! & potE(i,iparm),-entfac(i),rms_nat,iscore - potE(i,nparmset),-entfac(i),rms_nat,iscore -! write (iout,'(2i5,3e15.5)') i,me,potE(i,iparm),-entfac(i) -#ifndef MPI - if (cxfile) call cxwrite(ixdrf,csingle,potE(i,nparmset),& - -entfac(i),rms_nat,iscore) -#endif - enddo - close(ientout,status="delete") - close(istat) - if (bxfile .or. cxfile .or. ensembles.gt.0) close(ientin) -#ifdef MPI - call MPI_Barrier(WHAM_COMM,IERROR) - if (me.ne.Master .or. .not.bxfile .and. .not. cxfile & - .and. ensembles.eq.0) return - write (iout,*) - if (bxfile .or. ensembles.gt.0) then - if (nslice.eq.1) then - if (.not.separate_parset) then - bxname = prefix(:ilen(prefix))//".bx" - else - write (licz,'(bz,i3.3)') myparm - bxname = prefix(:ilen(prefix))//"_par"//licz//".bx" - endif - else - if (.not.separate_parset) then - bxname = prefix(:ilen(prefix))//"_slice_"//licz2//".bx" - else - write (licz,'(bz,i3.3)') myparm - bxname = prefix(:ilen(prefix))//"par_"//licz// & - "_slice_"//licz2//".bx" - endif - endif - open (ientout,file=bxname,status="unknown",& - form="unformatted",access="direct",recl=lenrec1) - write (iout,*) "Master is creating binary database ",& - bxname(:ilen(bxname)) - endif - if (cxfile) then - if (nslice.eq.1) then - if (.not.separate_parset) then - cxname = prefix(:ilen(prefix))//".cx" - else - cxname = prefix(:ilen(prefix))//"_par"//licz//".cx" - endif - else - if (.not.separate_parset) then - cxname = prefix(:ilen(prefix))// & - "_slice_"//licz2//".cx" - else - cxname = prefix(:ilen(prefix))//"_par"//licz// & - "_slice_"//licz2//".cx" - endif - endif -#if (defined(AIX) && !defined(JUBL)) - call xdrfopen_(ixdrf,cxname, "w", iret) -#else - call xdrfopen(ixdrf,cxname, "w", iret) -#endif - if (iret.eq.0) then - write (iout,*) "Error opening cxfile ",cxname(:ilen(cxname)) - cxfile=.false. - endif - endif - do j=0,nprocs-1 - write (liczba,'(bz,i3.3)') j - if (separate_parset) then - write (licz,'(bz,i3.3)') myparm - bxname = prefix(:ilen(prefix))//liczba//"_par"//licz//".bx" - else - bxname = prefix(:ilen(prefix))//liczba//".bx" - endif - open (ientin,file=bxname,status="unknown",& - form="unformatted",access="direct",recl=lenrec1) - write (iout,*) "Master is reading conformations from ",& - bxname(:ilen(bxname)) - iii = 0 -! write (iout,*) "j",j," indstart",indstart(j)," indend",indend(j) -! call flush(iout) - do i=indstart(j),indend(j) - iii = iii+1 - read(ientin,rec=iii,err=101) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,iscor - if (bxfile .or. ensembles.gt.0) then - write (ientout,rec=i) & - ((csingle(l,k),l=1,3),k=1,nres),& - ((csingle(l,k+nres),l=1,3),k=nnt,nct),& - nss,(ihpb(k),jhpb(k),k=1,nss),& - eini,efree,rmsdev,iscor - endif - if(cxfile)call cxwrite(ixdrf,csingle,eini,efree,rmsdev,iscor) -#ifdef DEBUG - do k=1,2*nres - do l=1,3 - c(l,k)=csingle(l,k) - enddo - enddo - call int_from_cart1(.false.) - write (iout,'(2i5,3e15.5)') i,iii,eini,efree - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) - write (iout,'(f10.5,i5)') rmsdev,iscor -#endif - enddo ! i - write (iout,*) iii," conformations (from",indstart(j)," to",& - indend(j),") read from ",& - bxname(:ilen(bxname)) - close (ientin,status="delete") - enddo ! j - if (bxfile .or. cxfile .or. ensembles.gt.0) close (ientout) -#if (defined(AIX) && !defined(JUBL)) - if (cxfile) call xdrfclose_(ixdrf,cxname,iret) -#else - if (cxfile) call xdrfclose(ixdrf,cxname,iret) -#endif -#endif - return - 101 write (iout,*) "Error in scratchfile." - call flush(iout) - return 1 - end subroutine write_dbase -!------------------------------------------------------------------------------- - subroutine cxwrite(ixdrf,csingle,eini,efree,rmsdev,iscor) -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! include "DIMENSIONS.COMPAR" -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif -! include "COMMON.CONTROL" -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.FFIELD" -! include "COMMON.ENEPS" -! include "COMMON.LOCAL" -! include "COMMON.WEIGHTS" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.COMPAR" -! include "COMMON.PROT" - integer :: i,j,itmp,iscor,iret,ixdrf - real(kind=8) :: rmsdev,efree,eini - real(kind=4) :: csingle(3,nres*2),xoord(3,2*nres+2) - real(kind=4) :: prec - -! write (iout,*) "cxwrite" -! call flush(iout) - prec=10000.0 - do i=1,nres - do j=1,3 - xoord(j,i)=csingle(j,i) - enddo - enddo - do i=nnt,nct - do j=1,3 - xoord(j,nres+i-nnt+1)=csingle(j,i+nres) - enddo - enddo - - itmp=nres+nct-nnt+1 - -! write (iout,*) "itmp",itmp -! call flush(iout) -#if (defined(AIX) && !defined(JUBL)) - call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) - -! write (iout,*) "xdrf3dfcoord" -! call flush(iout) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrffloat_(ixdrf,real(eini),iret) - call xdrffloat_(ixdrf,real(efree),iret) - call xdrffloat_(ixdrf,real(rmsdev),iret) - call xdrfint_(ixdrf,iscor,iret) -#else - call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) - - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrffloat(ixdrf,real(eini),iret) - call xdrffloat(ixdrf,real(efree),iret) - call xdrffloat(ixdrf,real(rmsdev),iret) - call xdrfint(ixdrf,iscor,iret) -#endif - - return - end subroutine cxwrite -!------------------------------------------------------------------------------- -! slices.F -!------------------------------------------------------------------------------- - subroutine set_slices(is,ie,ts,te,iR,ib,iparm) -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.PROTFILES' -! include 'COMMON.OBCINKA' -! include 'COMMON.PROT' - integer :: islice,iR,ib,iparm - integer :: is(MaxSlice),ie(MaxSlice),nrec_slice - real(kind=8) :: ts(MaxSlice),te(MaxSlice),time_slice - - do islice=1,nslice - if (time_end_collect(iR,ib,iparm).ge.1.0d10) then - ts(islice)=time_start_collect(iR,ib,iparm) - te(islice)=time_end_collect(iR,ib,iparm) - nrec_slice=(rec_end(iR,ib,iparm)- & - rec_start(iR,ib,iparm)+1)/nslice - is(islice)=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice - ie(islice)=rec_start(iR,ib,iparm)+islice*nrec_slice-1 - else - time_slice=(time_end_collect(iR,ib,iparm) & - -time_start_collect(iR,ib,iparm))/nslice - ts(islice)=time_start_collect(iR,ib,iparm)+(islice-1)* & - time_slice - te(islice)=time_start_collect(iR,ib,iparm)+islice*time_slice - is(islice)=rec_start(iR,ib,iparm) - ie(islice)=rec_end(iR,ib,iparm) - endif - enddo - - write (iout,*) "nrec_slice",nrec_slice," time_slice",time_slice - write (iout,*) "is",(is(islice),islice=1,nslice) - write (iout,*) "ie",(ie(islice),islice=1,nslice) - write (iout,*) "rec_start",& - rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) - write (iout,*) "ts",(ts(islice),islice=1,nslice) - write (iout,*) "te",(te(islice),islice=1,nslice) - write (iout,*) "time_start",& - time_start_collect(iR,ib,iparm)," time_end",& - time_end_collect(iR,ib,iparm) - call flush(iout) - - return - end subroutine set_slices -!----------------------------------------------------------------------------- - integer function slice(irecord,time,is,ie,ts,te) -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.PROTFILES' -! include 'COMMON.OBCINKA' -! include 'COMMON.PROT' - integer :: is(MaxSlice),ie(MaxSlice),nrec_slice - real(kind=8) :: ts(MaxSlice),te(MaxSlice),time_slice - integer :: i,ii,irecord - real(kind=8) :: time - -! write (iout,*) "within slice nslice",nslice -! call flush(iout) - if (irecord.lt.is(1) .or. time.lt.ts(1)) then - ii=0 - else - ii=1 - do while (ii.le.nslice .and. & - (irecord.lt.is(ii) .or. irecord.gt.ie(ii) .or. & - time.lt.ts(ii) .or. time.gt.te(ii)) ) -! write (iout,*) "ii",ii,time,ts(ii) -! call flush(iout) - ii=ii+1 - enddo - endif -! write (iout,*) "end: ii",ii -! call flush(iout) - slice=ii - return - end function slice -!----------------------------------------------------------------------------- -! enecalc1.F -!----------------------------------------------------------------------------- - logical function conf_check(ii,iprint) - - use names, only:ntyp1 - use geometry_data - use energy_data, only:itype,dsc - use geometry, only:int_from_cart1 -! use -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -!#ifdef MPI -! use MPI_data -! include "mpif.h" -! include "COMMON.MPI" -!#endif -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.VAR" -! include "COMMON.SBRIDGE" -! include "COMMON.GEO" -! include "COMMON.FFIELD" -! include "COMMON.ENEPS" -! include "COMMON.LOCAL" -! include "COMMON.WEIGHTS" -! include "COMMON.INTERACT" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.CONTROL" -! include "COMMON.TORCNSTR" -! implicit none -#ifdef MPI - include "mpif.h" - integer :: IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) -#endif - integer :: j,k,l,ii,itj,iprint - if (.not. check_conf) then - conf_check=.true. - return - endif - call int_from_cart1(.false.) - do j=nnt+1,nct - if (itype(j-1).ne.ntyp1 .and. itype(j).ne.ntyp1 .and. & - (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0)) then - if (iprint.gt.0) & - write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),& - " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) & - "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=nnt,nct - itj=itype(j) - if (itype(j).ne.10 .and.itype(j).ne.ntyp1 .and. & - (vbld(nres+j)-dsc(iabs(itj))).gt.2.0d0) then - if (iprint.gt.0) & - write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j),& - " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) & - "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=3,nres - if (theta(j).le.0.0d0) then - if (iprint.gt.0) & - write (iout,*) "Zero theta angle(s) in conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) & - "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad - enddo - conf_check=.true. -! write (iout,*) "conf_check passed",ii - return - end function conf_check -!----------------------------------------------------------------------------- - end module io_database diff --git a/source/wham/io_wham.F90 b/source/wham/io_wham.F90 new file mode 100644 index 0000000..23530b6 --- /dev/null +++ b/source/wham/io_wham.F90 @@ -0,0 +1,2765 @@ + module io_wham + + use io_units + use io_base + use wham_data +#ifndef CLUSTER + use w_compar_data +#endif +! use geometry_data +! use geometry + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! openunits.F +!----------------------------------------------------------------------------- +#ifndef CLUSTER + subroutine openunits +#ifdef WIN + use dfport +#endif +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + use MPI_data + include 'mpif.h' +! include 'COMMON.MPI' +! integer :: MyRank + character(len=3) :: liczba +#endif +! include 'COMMON.IOUNITS' + integer :: lenpre,lenpot !,ilen +!el external ilen + +#ifdef MPI + MyRank=Me +#endif + call mygetenv('PREFIX',prefix) + call mygetenv('SCRATCHDIR',scratchdir) + call mygetenv('POT',pot) + lenpre=ilen(prefix) + lenpot=ilen(pot) + call mygetenv('POT',pot) + entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' +! Get the names and open the input files + open (1,file=prefix(:ilen(prefix))//'.inp',status='old') +! Get parameter filenames and open the parameter files. + call mygetenv('BONDPAR',bondname) + open (ibond,file=bondname,status='old') + call mygetenv('THETPAR',thetname) + open (ithep,file=thetname,status='old') + call mygetenv('ROTPAR',rotname) + open (irotam,file=rotname,status='old') + call mygetenv('TORPAR',torname) + open (itorp,file=torname,status='old') + call mygetenv('TORDPAR',tordname) + open (itordp,file=tordname,status='old') + call mygetenv('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old') + call mygetenv('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old') + call mygetenv('ELEPAR',elename) + open (ielep,file=elename,status='old') + call mygetenv('SIDEPAR',sidename) + open (isidep,file=sidename,status='old') + call mygetenv('SIDEP',sidepname) + open (isidep1,file=sidepname,status="old") +#ifndef OLDSCP +! +! 8/9/01 In the newest version SCp interaction constants are read from a file +! Use -DOLDSCP to use hard-coded constants instead. +! + call mygetenv('SCPPAR',scpname) + open (iscpp,file=scpname,status='old') +#endif +#ifdef MPL + if (MyID.eq.BossID) then + MyRank = MyID/fgProcs +#endif +#ifdef MPI + print *,'OpenUnits: processor',MyRank + call numstr(MyRank,liczba) + outname=prefix(:lenpre)//'.out_'//pot(:lenpot)//liczba +#else + outname=prefix(:lenpre)//'.out_'//pot(:lenpot) +#endif + open(iout,file=outname,status='unknown') + write (iout,'(80(1h-))') + write (iout,'(30x,a)') "FILE ASSIGNMENT" + write (iout,'(80(1h-))') + write (iout,*) "Input file : ",& + prefix(:ilen(prefix))//'.inp' + write (iout,*) "Output file : ",& + outname(:ilen(outname)) + write (iout,*) + write (iout,*) "Sidechain potential file : ",& + sidename(:ilen(sidename)) +#ifndef OLDSCP + write (iout,*) "SCp potential file : ",& + scpname(:ilen(scpname)) +#endif + write (iout,*) "Electrostatic potential file : ",& + elename(:ilen(elename)) + write (iout,*) "Cumulant coefficient file : ",& + fouriername(:ilen(fouriername)) + write (iout,*) "Torsional parameter file : ",& + torname(:ilen(torname)) + write (iout,*) "Double torsional parameter file : ",& + tordname(:ilen(tordname)) + write (iout,*) "Backbone-rotamer parameter file : ",& + sccorname(:ilen(sccorname)) + write (iout,*) "Bond & inertia constant file : ",& + bondname(:ilen(bondname)) + write (iout,*) "Bending parameter file : ",& + thetname(:ilen(thetname)) + write (iout,*) "Rotamer parameter file : ",& + rotname(:ilen(rotname)) + write (iout,'(80(1h-))') + write (iout,*) + return + end subroutine openunits +!----------------------------------------------------------------------------- +! molread_zs.F +!----------------------------------------------------------------------------- + subroutine molread(*) +! +! Read molecular data. +! + use energy_data + use geometry_data, only:nres,deg2rad,c,dc + use control_data, only:iscode + use control, only:rescode,setup_var,init_int_table + use geometry, only:alloc_geo_arrays + use energy, only:alloc_ener_arrays +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! 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.TORCNSTR' +! include 'COMMON.CONTROL' + character(len=4),dimension(:),allocatable :: sequence !(nres) +!el integer :: rescode +!el real(kind=8) :: x(maxvar) + character(len=320) :: controlcard !,ucase + integer,dimension(nres) :: itype_pdb !(maxres) + integer :: i,j,i1,i2,it1,it2 + real(kind=8) :: scalscp +!el logical :: seq_comp + call card_concat(controlcard,.true.) + call reada(controlcard,'SCAL14',scal14,0.4d0) + call reada(controlcard,'SCALSCP',scalscp,1.0d0) + call reada(controlcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(controlcard,'TEMP0',temp0,300.0d0) !el + call reada(controlcard,'DELT_CORR',delt_corr,0.5d0) + r0_corr=cutoff_corr-delt_corr + call readi(controlcard,"NRES",nres,0) + allocate(sequence(nres+1)) +!el znamy juz ilosc reszt wiec mozna zaalokowac tablice do liczenia enerii + call alloc_geo_arrays + call alloc_ener_arrays +! alokacja dodatkowych tablic, ktore w unresie byly alokowanie w locie +!---------------------------- + allocate(c(3,2*nres+2)) + allocate(dc(3,0:2*nres+2)) + allocate(itype(nres+2)) + allocate(itel(nres+2)) +! +! Zero out tableis. + do i=1,2*nres+2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,nres+2 + itype(i)=0 + itel(i)=0 + enddo +!-------------------------- +! + iscode=index(controlcard,"ONE_LETTER") + if (nres.le.0) then + write (iout,*) "Error: no residues in molecule" + return 1 + endif + if (nres.gt.maxres) then + write (iout,*) "Error: too many residues",nres,maxres + endif + write(iout,*) 'nres=',nres +! Read sequence of the protein + if (iscode.gt.0) then + read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) + else + read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) + endif +! Convert sequence to numeric code + do i=1,nres + itype(i)=rescode(i,sequence(i),iscode) + enddo + write (iout,*) "Numeric code:" + write (iout,'(20i4)') (itype(i),i=1,nres) + do i=1,nres-1 +#ifdef PROCOR + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then +#else + if (itype(i).eq.ntyp1) then +#endif + itel(i)=0 +#ifdef PROCOR + else if (iabs(itype(i+1)).ne.20) then +#else + else if (iabs(itype(i)).ne.20) then +#endif + itel(i)=1 + else + itel(i)=2 + endif + enddo + write (iout,*) "ITEL" + do i=1,nres-1 + write (iout,*) i,itype(i),itel(i) + enddo + call read_bridge + + if (with_dihed_constr) then + + read (inp,*) ndih_constr + if (ndih_constr.gt.0) then + read (inp,*) ftors + write (iout,*) 'FTORS',ftors + read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) + write (iout,*) & + 'There are',ndih_constr,' constraints on phi angles.' + do i=1,ndih_constr + write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) + enddo + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + endif + + endif + + nnt=1 + nct=nres + if (itype(1).eq.ntyp1) nnt=2 + if (itype(nres).eq.ntyp1) nct=nct-1 + write(iout,*) 'NNT=',NNT,' NCT=',NCT + call setup_var + call init_int_table + if (ns.gt.0) then + write (iout,'(/a,i3,a)') 'The chain contains',ns,& + ' disulfide-bridging cysteines.' + write (iout,'(20i4)') (iss(i),i=1,ns) + write (iout,'(/a/)') 'Pre-formed links are:' + do i=1,nss + i1=ihpb(i)-nres + i2=jhpb(i)-nres + it1=itype(i1) + it2=itype(i2) + write (iout,'(2a,i3,3a,i3,a,3f10.3)') & + restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',& + dhpb(i),ebr,forcon(i) + enddo + endif + write (iout,'(a)') + return + end subroutine molread +!----------------------------------------------------------------------------- +! parmread.F +!----------------------------------------------------------------------------- + subroutine parmread(iparm,*) +#else + subroutine parmread +#endif +! +! Read the parameters of the probability distributions of the virtual-bond +! valence angles and the side chains and energy parameters. +! + use wham_data + + use geometry_data + use energy_data + use control_data, only: maxtor,maxterm,maxlor,maxterm_sccor,& + maxtermd_1,maxtermd_2,maxthetyp,maxthetyp1 + use MD_data +!el use MPI_data +!el use map_data + use io_config, only: printmat + use control, only: getenv_loc + +#ifdef MPI + use MPI_data + include "mpif.h" + integer :: IERROR +#endif +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.GEO' +! include 'COMMON.LOCAL' +! include 'COMMON.TORSION' +! include 'COMMON.FFIELD' +! include 'COMMON.NAMES' +! include 'COMMON.SBRIDGE' +! include 'COMMON.WEIGHTS' +! include 'COMMON.ENEPS' +! include 'COMMON.SCCOR' +! include 'COMMON.SCROT' +! include 'COMMON.FREE' + character(len=1) :: t1,t2,t3 + character(len=1) :: onelett(4) = (/"G","A","P","D"/) + character(len=1) :: toronelet(-2:2) = (/"p","a","G","A","P"/) + logical :: lprint + real(kind=8),dimension(3,3,maxlob) :: blower !(3,3,maxlob) + character(len=800) :: controlcard + character(len=256) :: bondname_t,thetname_t,rotname_t,torname_t,& + tordname_t,fouriername_t,elename_t,sidename_t,scpname_t,& + sccorname_t +!el integer ilen +!el external ilen + character(len=16) :: key + integer :: iparm +!el real(kind=8) :: ip,mp + real(kind=8) :: dwa16,akl,si,rri,epsij,rrij,sigeps,sigt1sq,& + sigt2sq,sigii1,sigii2,ratsig1,ratsig2,rsum_max,r_augm + real(kind=8) :: v0ij,v0ijsccor,v0ijsccor1,v0ijsccor2,v0ijsccor3,rjunk,& + res1 + integer :: i,j,ichir1,ichir2,k,l,m,kk,ii,mm,junk,lll,ll,llll,n + integer :: nlobi,iblock,maxinter,iscprol +! +! Body +! +! Set LPRINT=.TRUE. for debugging + dwa16=2.0d0**(1.0d0/6.0d0) + lprint=.false. + itypro=20 +! Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv +#ifndef CLUSTER + call card_concat(controlcard,.true.) + wname(4)="WCORRH" +!el +allocate(ww(max_eneW)) + do i=1,n_eneW + key = wname(i)(:ilen(wname(i))) + call reada(controlcard,key(:ilen(key)),ww(i),1.0d0) + enddo + + write (iout,*) "iparm",iparm," myparm",myparm +! If reading not own parameters, skip assignment + + if (iparm.eq.myparm .or. .not.separate_parset) then + +! +! Setup weights for UNRES +! + wsc=ww(1) + wscp=ww(2) + welec=ww(3) + wcorr=ww(4) + wcorr5=ww(5) + wcorr6=ww(6) + wel_loc=ww(7) + wturn3=ww(8) + wturn4=ww(9) + wturn6=ww(10) + wang=ww(11) + wscloc=ww(12) + wtor=ww(13) + wtor_d=ww(14) + wvdwpp=ww(16) + wbond=ww(18) + wsccor=ww(19) + + endif +! +!el------ + allocate(weights(n_ene)) + weights(1)=wsc + weights(2)=wscp + weights(3)=welec + weights(4)=wcorr + weights(5)=wcorr5 + weights(6)=wcorr6 + weights(7)=wel_loc + weights(8)=wturn3 + weights(9)=wturn4 + weights(10)=wturn6 + weights(11)=wang + weights(12)=wscloc + weights(13)=wtor + weights(14)=wtor_d + weights(15)=0 !wstrain ! + weights(16)=0 !wvdwpp ! + weights(17)=wbond + weights(18)=0 !scal14 ! + weights(21)=wsccor +! el-------- + call card_concat(controlcard,.false.) + +! Return if not own parameters + + if (iparm.ne.myparm .and. separate_parset) return + + call reads(controlcard,"BONDPAR",bondname_t,bondname) + open (ibond,file=bondname_t,status='old') + rewind(ibond) + call reads(controlcard,"THETPAR",thetname_t,thetname) + open (ithep,file=thetname_t,status='old') + rewind(ithep) + call reads(controlcard,"ROTPAR",rotname_t,rotname) + open (irotam,file=rotname_t,status='old') + rewind(irotam) + call reads(controlcard,"TORPAR",torname_t,torname) + open (itorp,file=torname_t,status='old') + rewind(itorp) + call reads(controlcard,"TORDPAR",tordname_t,tordname) + open (itordp,file=tordname_t,status='old') + rewind(itordp) + call reads(controlcard,"SCCORPAR",sccorname_t,sccorname) + open (isccor,file=sccorname_t,status='old') + rewind(isccor) + call reads(controlcard,"FOURIER",fouriername_t,fouriername) + open (ifourier,file=fouriername_t,status='old') + rewind(ifourier) + call reads(controlcard,"ELEPAR",elename_t,elename) + open (ielep,file=elename_t,status='old') + rewind(ielep) + call reads(controlcard,"SIDEPAR",sidename_t,sidename) + open (isidep,file=sidename_t,status='old') + rewind(isidep) + call reads(controlcard,"SCPPAR",scpname_t,scpname) + open (iscpp,file=scpname_t,status='old') + rewind(iscpp) + write (iout,*) "Parameter set:",iparm + write (iout,*) "Energy-term weights:" + do i=1,n_eneW + write (iout,'(a16,f10.5)') wname(i),ww(i) + enddo + write (iout,*) "Sidechain potential file : ",& + sidename_t(:ilen(sidename_t)) +#ifndef OLDSCP + write (iout,*) "SCp potential file : ",& + scpname_t(:ilen(scpname_t)) +#endif + write (iout,*) "Electrostatic potential file : ",& + elename_t(:ilen(elename_t)) + write (iout,*) "Cumulant coefficient file : ",& + fouriername_t(:ilen(fouriername_t)) + write (iout,*) "Torsional parameter file : ",& + torname_t(:ilen(torname_t)) + write (iout,*) "Double torsional parameter file : ",& + tordname_t(:ilen(tordname_t)) + write (iout,*) "Backbone-rotamer parameter file : ",& + sccorname(:ilen(sccorname)) + write (iout,*) "Bond & inertia constant file : ",& + bondname_t(:ilen(bondname_t)) + write (iout,*) "Bending parameter file : ",& + thetname_t(:ilen(thetname_t)) + write (iout,*) "Rotamer parameter file : ",& + rotname_t(:ilen(rotname_t)) +#endif +! +! Read the virtual-bond parameters, masses, and moments of inertia +! and Stokes' radii of the peptide group and side chains +! + allocate(dsc(ntyp1)) !(ntyp1) + allocate(dsc_inv(ntyp1)) !(ntyp1) + allocate(nbondterm(ntyp)) !(ntyp) + allocate(vbldsc0(maxbondterm,ntyp)) !(maxbondterm,ntyp) + allocate(aksc(maxbondterm,ntyp)) !(maxbondterm,ntyp) +!el allocate(msc(ntyp+1)) !(ntyp+1) +!el allocate(isc(ntyp+1)) !(ntyp+1) +!el allocate(restok(ntyp+1)) !(ntyp+1) + allocate(abond0(maxbondterm,ntyp)) !(maxbondterm,ntyp) + +#ifdef CRYST_BOND + read (ibond,*) vbldp0,akp + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*) vbldsc0(1,i),aksc(1,i) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#else + read (ibond,*) ijunk,vbldp0,akp,rjunk + do i=1,ntyp + read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i),& + j=1,nbondterm(i)) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#endif + if (lprint) then + write(iout,'(/a/)')"Force constants virtual bonds:" + write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K',& + 'inertia','Pstok' + write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0 + do i=1,ntyp + write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i),& + vbldsc0(1,i),aksc(1,i),abond0(1,i) + do j=2,nbondterm(i) + write (iout,'(13x,3f10.5)') & + vbldsc0(j,i),aksc(j,i),abond0(j,i) + enddo + enddo + endif +!---------------------------------------------------- + allocate(a0thet(-ntyp:ntyp),theta0(-ntyp:ntyp)) + allocate(sig0(-ntyp:ntyp),sigc0(-ntyp:ntyp)) !(-ntyp:ntyp) + allocate(athet(2,-ntyp:ntyp,-1:1,-1:1)) + allocate(bthet(2,-ntyp:ntyp,-1:1,-1:1)) !(2,-ntyp:ntyp,-1:1,-1:1) + allocate(polthet(0:3,-ntyp:ntyp)) !(0:3,-ntyp:ntyp) + allocate(gthet(3,-ntyp:ntyp)) !(3,-ntyp:ntyp) + do i=-ntyp,ntyp + 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 + enddo +!elwrite(iout,*) "parmread kontrol" + +#ifdef CRYST_THETA +! +! Read the parameters of the probability distribution/energy expression +! of the virtual-bond valence angles theta +! + do i=1,ntyp + read (ithep,*) a0thet(i),(athet(j,i,1,1),j=1,2),& + (bthet(j,i,1,1),j=1,2) + read (ithep,*) (polthet(j,i),j=0,3) +!elwrite(iout,*) "parmread kontrol in cryst_theta" + read (ithep,*) (gthet(j,i),j=1,3) +!elwrite(iout,*) "parmread kontrol in cryst_theta" + read (ithep,*) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 +!elwrite(iout,*) "parmread kontrol in cryst_theta" + enddo +!elwrite(iout,*) "parmread kontrol in cryst_theta" + do i=1,ntyp + athet(1,i,1,-1)=athet(1,i,1,1) + athet(2,i,1,-1)=athet(2,i,1,1) + bthet(1,i,1,-1)=-bthet(1,i,1,1) + bthet(2,i,1,-1)=-bthet(2,i,1,1) + athet(1,i,-1,1)=-athet(1,i,1,1) + athet(2,i,-1,1)=-athet(2,i,1,1) + bthet(1,i,-1,1)=bthet(1,i,1,1) + bthet(2,i,-1,1)=bthet(2,i,1,1) + enddo +!elwrite(iout,*) "parmread kontrol in cryst_theta" + do i=-ntyp,-1 + a0thet(i)=a0thet(-i) + athet(1,i,-1,-1)=athet(1,-i,1,1) + athet(2,i,-1,-1)=-athet(2,-i,1,1) + bthet(1,i,-1,-1)=bthet(1,-i,1,1) + bthet(2,i,-1,-1)=-bthet(2,-i,1,1) + athet(1,i,-1,1)=athet(1,-i,1,1) + athet(2,i,-1,1)=-athet(2,-i,1,1) + bthet(1,i,-1,1)=-bthet(1,-i,1,1) + bthet(2,i,-1,1)=bthet(2,-i,1,1) + athet(1,i,1,-1)=-athet(1,-i,1,1) + athet(2,i,1,-1)=athet(2,-i,1,1) + bthet(1,i,1,-1)=bthet(1,-i,1,1) + bthet(2,i,1,-1)=-bthet(2,-i,1,1) + theta0(i)=theta0(-i) + sig0(i)=sig0(-i) + sigc0(i)=sigc0(-i) + do j=0,3 + polthet(j,i)=polthet(j,-i) + enddo + do j=1,3 + gthet(j,i)=gthet(j,-i) + enddo + enddo +!elwrite(iout,*) "parmread kontrol in cryst_theta" + close (ithep) +!elwrite(iout,*) "parmread kontrol in cryst_theta" + if (lprint) then +! write (iout,'(a)') +! & 'Parameters of the virtual-bond valence angles:' +! write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', +! & ' ATHETA0 ',' A1 ',' A2 ', +! & ' B1 ',' B2 ' +! do i=1,ntyp +! write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +! & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) +! enddo +! write (iout,'(/a/9x,5a/79(1h-))') +! & 'Parameters of the expression for sigma(theta_c):', +! & ' ALPH0 ',' ALPH1 ',' ALPH2 ', +! & ' ALPH3 ',' SIGMA0C ' +! do i=1,ntyp +! write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +! & (polthet(j,i),j=0,3),sigc0(i) +! enddo +! write (iout,'(/a/9x,5a/79(1h-))') +! & 'Parameters of the second gaussian:', +! & ' THETA0 ',' SIGMA0 ',' G1 ', +! & ' G2 ',' G3 ' +! do i=1,ntyp +! write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), +! & sig0(i),(gthet(j,i),j=1,3) +! enddo + write (iout,'(a)') & + 'Parameters of the virtual-bond valence angles:' + write (iout,'(/a/9x,5a/79(1h-))') & + 'Coefficients of expansion',& + ' theta0 ',' a1*10^2 ',' a2*10^2 ',& + ' b1*10^1 ',' b2*10^1 ' + do i=1,ntyp + write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),& + a0thet(i),(100*athet(j,i,1,1),j=1,2),& + (10*bthet(j,i,1,1),j=1,2) + enddo + write (iout,'(/a/9x,5a/79(1h-))') & + 'Parameters of the expression for sigma(theta_c):',& + ' alpha0 ',' alph1 ',' alph2 ',& + ' alhp3 ',' sigma0c ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i),& + (polthet(j,i),j=0,3),sigc0(i) + enddo + write (iout,'(/a/9x,5a/79(1h-))') & + 'Parameters of the second gaussian:',& + ' theta0 ',' sigma0*10^2 ',' G1*10^-1',& + ' G2 ',' G3*10^1 ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i),& + 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 + enddo + endif +#else +! +! Read the parameters of Utheta determined from ab initio surfaces +! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +! +! write (iout,*) "tu dochodze" + read (ithep,*) nthetyp,ntheterm,ntheterm2,& + ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + +!---------------------------------------------------- + allocate(ithetyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) + allocate(aa0thet(-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + allocate(aathet(ntheterm,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(maxtheterm,-maxthetyp1:maxthetyp1,& +! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + allocate(bbthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(ccthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(ddthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(eethet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& +! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) + allocate(ffthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + allocate(ggthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& + -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) +!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,& +! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) + + + read (ithep,*) (ithetyp(i),i=1,ntyp1) + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo +! write (iout,*) "tu dochodze" + do iblock=1,2 + do i=-maxthetyp,maxthetyp + do j=-maxthetyp,maxthetyp + do k=-maxthetyp,maxthetyp + aa0thet(i,j,k,iblock)=0.0d0 + do l=1,ntheterm + aathet(l,i,j,k,iblock)=0.0d0 + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet(m,l,i,j,k,iblock)=0.0d0 + ccthet(m,l,i,j,k,iblock)=0.0d0 + ddthet(m,l,i,j,k,iblock)=0.0d0 + eethet(m,l,i,j,k,iblock)=0.0d0 + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + ffthet(mm,m,l,i,j,k,iblock)=0.0d0 + ggthet(mm,m,l,i,j,k,iblock)=0.0d0 + enddo + enddo + enddo + enddo + enddo + enddo + enddo + do iblock=1,2 + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)') res1 + read (ithep,*) aa0thet(i,j,k,iblock) + read (ithep,*)(aathet(l,i,j,k,iblock),l=1,ntheterm) + read (ithep,*) & + ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle),& + ll=1,ntheterm2) + read (ithep,*) & + (((ffthet(llll,lll,ll,i,j,k,iblock),& + ffthet(lll,llll,ll,i,j,k,iblock),& + ggthet(llll,lll,ll,i,j,k,iblock),& + ggthet(lll,llll,ll,i,j,k,iblock),& + llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) + enddo + enddo + enddo +! +! For dummy ends assign glycine-type coefficients of theta-only terms; the +! coefficients of theta-and-gamma-dependent terms are zero. +! + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1,iblock)=0.0d0 + aathet(l,nthetyp+1,i,j,iblock)=0.0d0 + enddo + aa0thet(i,j,nthetyp+1,iblock)=0.0d0 + aa0thet(nthetyp+1,i,j,iblock)=0.0d0 + enddo + do l=1,ntheterm + aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 + enddo + aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 + enddo + enddo +! Substitution for D aminoacids from symmetry. + do iblock=1,2 + do i=-nthetyp,0 + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock) + do l=1,ntheterm + aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock) + enddo + do ll=1,ntheterm2 + do lll=1,nsingle + bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock) + ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock) + ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock) + eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock) + enddo + enddo + do ll=1,ntheterm3 + do lll=2,ndouble + do llll=1,lll-1 + ffthet(llll,lll,ll,i,j,k,iblock)= & + ffthet(llll,lll,ll,-i,-j,-k,iblock) + ffthet(lll,llll,ll,i,j,k,iblock)= & + ffthet(lll,llll,ll,-i,-j,-k,iblock) + ggthet(llll,lll,ll,i,j,k,iblock)= & + -ggthet(llll,lll,ll,-i,-j,-k,iblock) + ggthet(lll,llll,ll,i,j,k,iblock)= & + -ggthet(lll,llll,ll,-i,-j,-k,iblock) + enddo !ll + enddo !lll + enddo !llll + enddo !k + enddo !j + enddo !i + enddo !iblock + +! +! Control printout of the coefficients of virtual-bond-angle potentials +! +do iblock=1,2 + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do i=1,nthetyp+1 + do j=1,nthetyp+1 + do k=1,nthetyp+1 + write (iout,'(//4a)') & + 'Type ',onelett(i),onelett(j),onelett(k) + write (iout,'(//a,10x,a)') " l","a[l]" + write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) + write (iout,'(i2,1pe15.5)') & + (l,aathet(l,i,j,k,iblock),l=1,ntheterm) + do l=1,ntheterm2 + write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') & + "b",l,"c",l,"d",l,"e",l + do m=1,nsingle + write (iout,'(i2,4(1pe15.5))') m,& + bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock),& + ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) + enddo + enddo + do l=1,ntheterm3 + write (iout,'(//3hm,n,4(6x,a,5h[m,n,i1,1h]))') & + "f+",l,"f-",l,"g+",l,"g-",l + do m=2,ndouble + do n=1,m-1 + write (iout,'(i1,1x,i1,4(1pe15.5))') n,m,& + ffthet(n,m,l,i,j,k,iblock),& + ffthet(m,n,l,i,j,k,iblock),& + ggthet(n,m,l,i,j,k,iblock),& + ggthet(m,n,l,i,j,k,iblock) + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + endif +enddo +#endif +!------------------------------------------- + allocate(nlob(ntyp1)) !(ntyp1) + allocate(bsc(maxlob,ntyp)) !(maxlob,ntyp) + allocate(censc(3,maxlob,-ntyp:ntyp)) !(3,maxlob,-ntyp:ntyp) + allocate(gaussc(3,3,maxlob,-ntyp:ntyp)) !(3,3,maxlob,-ntyp:ntyp) + + do i=1,ntyp + do j=1,maxlob + bsc(j,i)=0.0D0 + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + + do i=-ntyp,ntyp + do j=1,maxlob + 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 + enddo + enddo + +#ifdef CRYST_SC +! +! Read the parameters of the probability distribution/energy expression +! of the side chains. +! + do i=1,ntyp +!c write (iout,*) "tu dochodze",i + read (irotam,'(3x,i3,f8.3)') nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam,*)(censc(k,1,i),k=1,3),((blower(k,l,1),l=1,k),k=1,3) + censc(1,1,-i)=censc(1,1,i) + censc(2,1,-i)=censc(2,1,i) + censc(3,1,-i)=-censc(3,1,i) + do j=2,nlob(i) + read (irotam,*) bsc(j,i) + read (irotam,*) (censc(k,j,i),k=1,3),& + ((blower(k,l,j),l=1,k),k=1,3) + censc(1,j,-i)=censc(1,j,i) + censc(2,j,-i)=censc(2,j,i) + censc(3,j,-i)=-censc(3,j,i) +! BSC is amplitude of Gaussian + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + if (((k.eq.3).and.(l.ne.3)) & + .or.((l.eq.3).and.(k.ne.3))) then + gaussc(k,l,j,-i)=-akl + gaussc(l,k,j,-i)=-akl + else + gaussc(k,l,j,-i)=akl + gaussc(l,k,j,-i)=akl + endif + enddo + enddo + enddo + endif + enddo + close (irotam) + if (lprint) then + write (iout,'(/a)') 'Parameters of side-chain local geometry' + do i=1,ntyp + nlobi=nlob(i) + if (nlobi.gt.0) then + write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i),& + ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) +! write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) +! write (iout,'(a,f10.4,4(16x,f10.4))') +! & 'Center ',(bsc(j,i),j=1,nlobi) +! write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3),j=1,nlobi) + write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') & + 'log h',(bsc(j,i),j=1,nlobi) + write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') & + 'x',((censc(k,j,i),k=1,3),j=1,nlobi) +! write (iout,'(a)') +! do j=1,nlobi +! ind=0 +! do k=1,3 +! do l=1,k +! ind=ind+1 +! blower(k,l,j)=gaussc(ind,j,i) +! enddo +! enddo +! enddo + do k=1,3 + write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') & + ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) + enddo + endif + enddo + endif +#else +! +! Read scrot parameters for potentials determined from all-atom AM1 calculations +! added by Urszula Kozlowska 07/11/2007 +! + allocate(sc_parmin(65,ntyp)) !(maxsccoef,ntyp) + + do i=1,ntyp + read (irotam,*) + if (i.eq.10) then + read (irotam,*) + else + do j=1,65 + read(irotam,*) sc_parmin(j,i) + enddo + endif + enddo +#endif + close(irotam) +#ifdef CRYST_TOR +! +! Read torsional parameters in old format +! + allocate(itortyp(ntyp1)) !(-ntyp1:ntyp1) + + read (itorp,*) ntortyp,nterm_old + write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*) (itortyp(i),i=1,ntyp) + +!el from energy module-------- + allocate(v1(nterm_old,ntortyp,ntortyp)) + allocate(v2(nterm_old,ntortyp,ntortyp)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor) +!el--------------------------- + + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)') + do k=1,nterm_old + read (itorp,*) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif + + +#else +! +! Read torsional parameters +! + allocate(itortyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) + + read (itorp,*) ntortyp + read (itorp,*) (itortyp(i),i=1,ntyp) + write (iout,*) 'ntortyp',ntortyp + +!el from energy module--------- + allocate(nterm(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) + allocate(nlor(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) + + allocate(vlor1(maxlor,-ntortyp:ntortyp,-ntortyp:ntortyp)) !(maxlor,-maxtor:maxtor,-maxtor:maxtor) + allocate(vlor2(maxlor,ntortyp,ntortyp)) + allocate(vlor3(maxlor,ntortyp,ntortyp)) !(maxlor,maxtor,maxtor) + allocate(v0(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) + + allocate(v1(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) + allocate(v2(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) +!el--------------------------- + do iblock=1,2 + do i=-ntortyp,ntortyp + do j=-ntortyp,ntortyp + nterm(i,j,iblock)=0 + nlor(i,j,iblock)=0 + enddo + enddo + enddo +!el--------------------------- + + do iblock=1,2 + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +! write (iout,*) 'ntortyp',ntortyp + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + read (itorp,*) nterm(i,j,iblock),& + nlor(i,j,iblock) + nterm(-i,-j,iblock)=nterm(i,j,iblock) + nlor(-i,-j,iblock)=nlor(i,j,iblock) + v0ij=0.0d0 + si=-1.0d0 + do k=1,nterm(i,j,iblock) + read (itorp,*) kk,v1(k,i,j,iblock),& + v2(k,i,j,iblock) + v1(k,-i,-j,iblock)=v1(k,i,j,iblock) + v2(k,-i,-j,iblock)=-v2(k,i,j,iblock) + v0ij=v0ij+si*v1(k,i,j,iblock) + si=-si + enddo + do k=1,nlor(i,j,iblock) + read (itorp,*) kk,vlor1(k,i,j),& + vlor2(k,i,j),vlor3(k,i,j) + v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) + enddo + v0(i,j,iblock)=v0ij + v0(-i,-j,iblock)=v0ij + enddo + enddo + enddo + close (itorp) + if (lprint) then + do iblock=1,2 !el + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm(i,j,iblock) + write (iout,'(2(1pe15.5))') v1(k,i,j,iblock),& + v2(k,i,j,iblock) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor(i,j,iblock) + write (iout,'(3(1pe15.5))') & + vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) + enddo + enddo + enddo + enddo + endif +! +! 6/23/01 Read parameters for double torsionals +! +!el from energy module------------ + allocate(v1c(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + allocate(v1s(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) +!(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) + allocate(v2c(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + allocate(v2s(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) + allocate(ntermd_1(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + allocate(ntermd_2(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) + !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +!--------------------------------- + + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + read (itordp,'(3a1)') t1,t2,t3 +! write (iout,*) "OK onelett", +! & i,j,k,t1,t2,t3 + + if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j) & + .or. t3.ne.toronelet(k)) then + write (iout,*) "Error in double torsional parameter file",& + i,j,k,t1,t2,t3 +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop "Error in double torsional parameter file" + endif + read (itordp,*) ntermd_1(i,j,k,iblock),& + ntermd_2(i,j,k,iblock) + ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock) + ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock) + read (itordp,*) (v1c(1,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1s(1,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1c(2,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1s(2,l,i,j,k,iblock),l=1,& + ntermd_1(i,j,k,iblock)) +! Martix of D parameters for one dimesional foureir series + do l=1,ntermd_1(i,j,k,iblock) + v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock) + v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock) + v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock) + v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock) +! write(iout,*) "whcodze" , +! & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock) + enddo + read (itordp,*) ((v2c(l,m,i,j,k,iblock),& + v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock),& + v2s(m,l,i,j,k,iblock),& + m=1,l-1),l=1,ntermd_2(i,j,k,iblock)) +! Martix of D parameters for two dimesional fourier series + do l=1,ntermd_2(i,j,k,iblock) + do m=1,l-1 + v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock) + v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock) + v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock) + v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock) + enddo!m + enddo!l + enddo!k + enddo!j + enddo!i + enddo!iblock + if (lprint) then + write (iout,*) + write (iout,*) 'Constants for double torsionals' + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,& + ' nsingle',ntermd_1(i,j,k,iblock),& + ' ndouble',ntermd_2(i,j,k,iblock) + write (iout,*) + write (iout,*) 'Single angles:' + do l=1,ntermd_1(i,j,k,iblock) + write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l,& + v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock),& + v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock),& + v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock) + enddo + write (iout,*) + write (iout,*) 'Pairs of angles:' + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') & + l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)) + enddo + write (iout,*) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') & + l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)),& + (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock)) + enddo + write (iout,*) + enddo + enddo + enddo + enddo + endif +#endif +!elwrite(iout,*) "parmread kontrol sc-bb" +! Read of Side-chain backbone correlation parameters +! Modified 11 May 2012 by Adasko +!CC +! + read (isccor,*) nsccortyp + + maxinter=3 +!c maxinter is maximum interaction sites +!write(iout,*)"maxterm_sccor",maxterm_sccor +!el from module energy------------- + allocate(nlor_sccor(nsccortyp,nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) + allocate(vlor1sccor(maxterm_sccor,nsccortyp,nsccortyp)) + allocate(vlor2sccor(maxterm_sccor,nsccortyp,nsccortyp)) + allocate(vlor3sccor(maxterm_sccor,nsccortyp,nsccortyp)) !(maxterm_sccor,20,20) +!----------------------------------- + allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) +!----------------------------------- + allocate(nterm_sccor(-nsccortyp:nsccortyp,-nsccortyp:nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) + allocate(v1sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& + -nsccortyp:nsccortyp)) + allocate(v2sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& + -nsccortyp:nsccortyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) + allocate(v0sccor(maxinter,-nsccortyp:nsccortyp,& + -nsccortyp:nsccortyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) +!----------------------------------- + do i=-nsccortyp,nsccortyp + do j=-nsccortyp,nsccortyp + nterm_sccor(j,i)=0 + enddo + enddo +!----------------------------------- + + read (isccor,*) (isccortyp(i),i=1,ntyp) + do i=-ntyp,-1 + isccortyp(i)=-isccortyp(-i) + enddo + iscprol=isccortyp(20) +! write (iout,*) 'ntortyp',ntortyp +! maxinter=3 +!c maxinter is maximum interaction sites + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*) & + nterm_sccor(i,j),nlor_sccor(i,j) + v0ijsccor=0.0d0 + v0ijsccor1=0.0d0 + v0ijsccor2=0.0d0 + v0ijsccor3=0.0d0 + si=-1.0d0 + nterm_sccor(-i,j)=nterm_sccor(i,j) + nterm_sccor(-i,-j)=nterm_sccor(i,j) + nterm_sccor(i,-j)=nterm_sccor(i,j) + do k=1,nterm_sccor(i,j) + read (isccor,*) kk,v1sccor(k,l,i,j),& + v2sccor(k,l,i,j) + if (j.eq.iscprol) then + if (i.eq.isccortyp(10)) then + v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) + else + v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0 & + +v2sccor(k,l,i,j)*dsqrt(0.75d0) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0 & + +v1sccor(k,l,i,j)*dsqrt(0.75d0) + v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) + v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) + v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) + endif + else + if (i.eq.isccortyp(10)) then + v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) + else + if (j.eq.isccortyp(10)) then + v1sccor(k,l,-i,j)=v1sccor(k,l,i,j) + v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j) + else + v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j) + v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) + v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) + v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) + v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) + v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) + endif + endif + endif + v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) + v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j) + v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j) + v0ijsccor3=v0ijsccor+si*v1sccor(k,l,-i,-j) + si=-si + enddo + do k=1,nlor_sccor(i,j) + read (isccor,*) kk,vlor1sccor(k,i,j),& + vlor2sccor(k,i,j),vlor3sccor(k,i,j) + v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ & + (1+vlor3sccor(k,i,j)**2) + enddo + v0sccor(l,i,j)=v0ijsccor + v0sccor(l,-i,j)=v0ijsccor1 + v0sccor(l,i,-j)=v0ijsccor2 + v0sccor(l,-i,-j)=v0ijsccor3 + enddo + enddo + enddo + close (isccor) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants of SCCORR:' + do i=1,nsccortyp + do j=1,nsccortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm_sccor(i,j) + write (iout,'(2(1pe15.5))') & + (v1sccor(k,l,i,j),v2sccor(k,l,i,j),l=1,maxinter) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor_sccor(i,j) + write (iout,'(3(1pe15.5))') & + vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) + enddo + enddo + enddo + endif +! +! 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +! interaction energy of the Gly, Ala, and Pro prototypes. +! + read (ifourier,*) nloctyp +!el write(iout,*)"nloctyp",nloctyp +!el from module energy------- + allocate(b1(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) + allocate(b2(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) + allocate(b1tilde(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) + allocate(cc(2,2,-nloctyp-1:nloctyp+1)) + allocate(dd(2,2,-nloctyp-1:nloctyp+1)) + allocate(ee(2,2,-nloctyp-1:nloctyp+1)) + allocate(ctilde(2,2,-nloctyp-1:nloctyp+1)) + allocate(dtilde(2,2,-nloctyp-1:nloctyp+1)) !(2,2,-maxtor:maxtor) + do i=1,2 + do ii=-nloctyp-1,nloctyp+1 + b1(i,ii)=0.0d0 + b2(i,ii)=0.0d0 + b1tilde(i,ii)=0.0d0 + do j=1,2 + cc(j,i,ii)=0.0d0 + dd(j,i,ii)=0.0d0 + ee(j,i,ii)=0.0d0 + ctilde(j,i,ii)=0.0d0 + dtilde(j,i,ii)=0.0d0 + enddo + enddo + enddo +!-------------------------------- + allocate(b(13,0:nloctyp)) + + do i=0,nloctyp-1 + read (ifourier,*) + read (ifourier,*) (b(ii,i),ii=1,13) + if (lprint) then + write (iout,*) 'Type',i + write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) + endif + B1(1,i) = b(3,i) + B1(2,i) = b(5,i) + B1(1,-i) = b(3,i) + B1(2,-i) = -b(5,i) +! b1(1,i)=0.0d0 +! b1(2,i)=0.0d0 + B1tilde(1,i) = b(3,i) + B1tilde(2,i) =-b(5,i) + B1tilde(1,-i) =-b(3,i) + B1tilde(2,-i) =b(5,i) +! b1tilde(1,i)=0.0d0 +! b1tilde(2,i)=0.0d0 + B2(1,i) = b(2,i) + B2(2,i) = b(4,i) + B2(1,-i) =b(2,i) + B2(2,-i) =-b(4,i) + +! b2(1,i)=0.0d0 +! b2(2,i)=0.0d0 + CC(1,1,i)= b(7,i) + CC(2,2,i)=-b(7,i) + CC(2,1,i)= b(9,i) + CC(1,2,i)= b(9,i) + CC(1,1,-i)= b(7,i) + CC(2,2,-i)=-b(7,i) + CC(2,1,-i)=-b(9,i) + CC(1,2,-i)=-b(9,i) +! CC(1,1,i)=0.0d0 +! CC(2,2,i)=0.0d0 +! CC(2,1,i)=0.0d0 +! CC(1,2,i)=0.0d0 + Ctilde(1,1,i)=b(7,i) + Ctilde(1,2,i)=b(9,i) + Ctilde(2,1,i)=-b(9,i) + Ctilde(2,2,i)=b(7,i) + Ctilde(1,1,-i)=b(7,i) + Ctilde(1,2,-i)=-b(9,i) + Ctilde(2,1,-i)=b(9,i) + Ctilde(2,2,-i)=b(7,i) + +! Ctilde(1,1,i)=0.0d0 +! Ctilde(1,2,i)=0.0d0 +! Ctilde(2,1,i)=0.0d0 +! Ctilde(2,2,i)=0.0d0 + DD(1,1,i)= b(6,i) + DD(2,2,i)=-b(6,i) + DD(2,1,i)= b(8,i) + DD(1,2,i)= b(8,i) + DD(1,1,-i)= b(6,i) + DD(2,2,-i)=-b(6,i) + DD(2,1,-i)=-b(8,i) + DD(1,2,-i)=-b(8,i) +! DD(1,1,i)=0.0d0 +! DD(2,2,i)=0.0d0 +! DD(2,1,i)=0.0d0 +! DD(1,2,i)=0.0d0 + Dtilde(1,1,i)=b(6,i) + Dtilde(1,2,i)=b(8,i) + Dtilde(2,1,i)=-b(8,i) + Dtilde(2,2,i)=b(6,i) + Dtilde(1,1,-i)=b(6,i) + Dtilde(1,2,-i)=-b(8,i) + Dtilde(2,1,-i)=b(8,i) + Dtilde(2,2,-i)=b(6,i) + +! Dtilde(1,1,i)=0.0d0 +! Dtilde(1,2,i)=0.0d0 +! Dtilde(2,1,i)=0.0d0 +! Dtilde(2,2,i)=0.0d0 + EE(1,1,i)= b(10,i)+b(11,i) + EE(2,2,i)=-b(10,i)+b(11,i) + EE(2,1,i)= b(12,i)-b(13,i) + EE(1,2,i)= b(12,i)+b(13,i) + EE(1,1,-i)= b(10,i)+b(11,i) + EE(2,2,-i)=-b(10,i)+b(11,i) + EE(2,1,-i)=-b(12,i)+b(13,i) + EE(1,2,-i)=-b(12,i)-b(13,i) + +! ee(1,1,i)=1.0d0 +! ee(2,2,i)=1.0d0 +! ee(2,1,i)=0.0d0 +! ee(1,2,i)=0.0d0 +! ee(2,1,i)=ee(1,2,i) + + enddo + if (lprint) then + do i=1,nloctyp + write (iout,*) 'Type',i + write (iout,*) 'B1' +! write (iout,'(f10.5)') B1(:,i) + write(iout,*) B1(1,i),B1(2,i) + write (iout,*) 'B2' +! write (iout,'(f10.5)') B2(:,i) + write(iout,*) B2(1,i),B2(2,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) + enddo + enddo + endif +! +! Read electrostatic-interaction parameters +! + if (lprint) then + write (iout,'(/a)') 'Electrostatic interaction constants:' + write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') & + 'IT','JT','APP','BPP','AEL6','AEL3' + endif + read (ielep,*) ((epp(i,j),j=1,2),i=1,2) + read (ielep,*) ((rpp(i,j),j=1,2),i=1,2) + read (ielep,*) ((elpp6(i,j),j=1,2),i=1,2) + read (ielep,*) ((elpp3(i,j),j=1,2),i=1,2) + close (ielep) + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + app (i,j)=epp(i,j)*rri*rri + bpp (i,j)=-2.0D0*epp(i,j)*rri + ael6(i,j)=elpp6(i,j)*4.2D0**6 + ael3(i,j)=elpp3(i,j)*4.2D0**3 + if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j),& + ael6(i,j),ael3(i,j) + enddo + enddo +! +! Read side-chain interaction parameters. +! +!el from module energy - COMMON.INTERACT------- + allocate(eps(ntyp,ntyp),sigmaii(ntyp,ntyp),rs0(ntyp,ntyp)) !(ntyp,ntyp) + allocate(augm(ntyp,ntyp)) !(ntyp,ntyp) + allocate(eps_scp(ntyp,2),rscp(ntyp,2)) !(ntyp,2) + allocate(sigma0(ntyp),rr0(ntyp),sigii(ntyp)) !(ntyp) + allocate(chip(ntyp1),alp(ntyp1)) !(ntyp) + do i=1,ntyp + do j=1,ntyp + augm(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 + enddo +!-------------------------------- + + read (isidep,*) ipot,expon +!el if (ipot.lt.1 .or. ipot.gt.5) then +! write (iout,'(2a)') 'Error while reading SC interaction',& +! 'potential file - unknown potential type.' +! stop +!wl endif + expon2=expon/2 + write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot),& + ', exponents are ',expon,2*expon +! goto (10,20,30,30,40) ipot + select case(ipot) +!----------------------- LJ potential --------------------------------- + case (1) +! 10 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),(sigma0(i),i=1,ntyp) + read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),(sigma0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJ potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,a)') 'residue','sigma' + write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) + endif +! goto 50 +!----------------------- LJK potential -------------------------------- + case (2) +! 20 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& + read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& + (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJK potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' + write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i),& + i=1,ntyp) + endif +! goto 50 +!---------------------- GB or BP potential ----------------------------- + case (3:4) +! 30 do i=1,ntyp + do i=1,ntyp + read (isidep,*)(eps(i,j),j=i,ntyp) + enddo + read (isidep,*)(sigma0(i),i=1,ntyp) + read (isidep,*)(sigii(i),i=1,ntyp) + read (isidep,*)(chip(i),i=1,ntyp) + read (isidep,*)(alp(i),i=1,ntyp) +! For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2',& + ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i),& + chip(i),alp(i),i=1,ntyp) + endif +! goto 50 +!--------------------- GBV potential ----------------------------------- + case (5) +! 40 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& + read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& + (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp),& + (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the GBV potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ',& + 's||/s_|_^2',' chip ',' alph ' + write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i),& + sigii(i),chip(i),alp(i),i=1,ntyp) + endif + case default + write (iout,'(2a)') 'Error while reading SC interaction',& + 'potential file - unknown potential type.' + stop +! 50 continue + end select +! continue + close (isidep) +!----------------------------------------------------------------------- +! Calculate the "working" parameters of SC interactions. + +!el from module energy - COMMON.INTERACT------- + allocate(aa(ntyp1,ntyp1),bb(ntyp1,ntyp1),chi(ntyp1,ntyp1)) !(ntyp,ntyp) + allocate(sigma(0:ntyp1,0:ntyp1),r0(ntyp1,ntyp1)) !(0:ntyp1,0:ntyp1) + do i=1,ntyp1 + do j=1,ntyp1 + aa(i,j)=0.0D0 + bb(i,j)=0.0D0 + chi(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + enddo + enddo +!-------------------------------- + + do i=2,ntyp + do j=1,i-1 + eps(i,j)=eps(j,i) + enddo + enddo + do i=1,ntyp + do j=i,ntyp + sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) + sigma(j,i)=sigma(i,j) + rs0(i,j)=dwa16*sigma(i,j) + rs0(j,i)=rs0(i,j) + enddo + enddo + if (lprint) write (iout,'(/a/10x,7a/72(1h-))') & + 'Working parameters of the SC interactions:',& + ' a ',' b ',' augm ',' sigma ',' r0 ',& + ' chi1 ',' chi2 ' + do i=1,ntyp + do j=i,ntyp + epsij=eps(i,j) + if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + rrij=sigma(i,j) + else + rrij=rr0(i)+rr0(j) + endif + r0(i,j)=rrij + r0(j,i)=rrij + rrij=rrij**expon + epsij=eps(i,j) + sigeps=dsign(1.0D0,epsij) + epsij=dabs(epsij) + aa(i,j)=epsij*rrij*rrij + bb(i,j)=-sigeps*epsij*rrij + aa(j,i)=aa(i,j) + bb(j,i)=bb(i,j) + if (ipot.gt.2) then + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +! if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +! else +! sigmaii(i,j)=r0(i,j) +! sigmaii(j,i)=r0(i,j) +! endif +!d write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +! augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') & + restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j),& + sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + endif + enddo + enddo + + allocate(aad(ntyp,2),bad(ntyp,2)) !(ntyp,2) + do i=1,ntyp + do j=1,2 + bad(i,j)=0.0D0 + enddo + enddo +#ifdef CLUSTER +! +! Define the SC-p interaction constants +! + do i=1,20 + do j=1,2 + eps_scp(i,j)=-1.5d0 + rscp(i,j)=4.0d0 + enddo + enddo +#endif + +!elwrite(iout,*) "parmread kontrol before oldscp" +! +! Define the SC-p interaction constants +! +#ifdef OLDSCP + do i=1,20 +! "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +! helix formation) +! aad(i,1)=0.3D0*4.0D0**12 +! Following line for constants currently implemented +! "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +! aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +! "Soft" SC-p repulsion + bad(i,1)=0.0D0 +! Following line for constants currently implemented +! aad(i,1)=0.3D0*4.0D0**6 +! "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +! bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +! aad(i,1)=0.0D0 +! aad(i,2)=0.0D0 +! bad(i,1)=1228.8D0 +! bad(i,2)=1228.8D0 + enddo +#else +! +! 8/9/01 Read the SC-p interaction constants from file +! + do i=1,ntyp + read (iscpp,*) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo + + if (lprint) then + write (iout,*) "Parameters of SC-p interactions:" + do i=1,20 + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1),& + eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +#endif +! +! Define the constants of the disulfide bridge +! + ebr=-5.50D0 +! +! Old arbitrary potential - commented out. +! +! dbr= 4.20D0 +! fbr= 3.30D0 +! +! Constants of the disulfide-bond potential determined based on the RHF/6-31G** +! energy surface of diethyl disulfide. +! A. Liwo and U. Kozlowska, 11/24/03 +! + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 + + if (lprint) then + write (iout,'(/a)') "Disulfide bridge parameters:" + write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr + write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm + write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct + write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,& + ' v3ss:',v3ss + endif + return + end subroutine parmread +#ifndef CLUSTER +!----------------------------------------------------------------------------- +! mygetenv.F +!----------------------------------------------------------------------------- + subroutine mygetenv(string,var) +! +! Version 1.0 +! +! This subroutine passes the environmental variables to FORTRAN program. +! If the flags -DMYGETENV and -DMPI are not for compilation, it calls the +! standard FORTRAN GETENV subroutine. If both flags are set, the subroutine +! reads the environmental variables from $HOME/.env +! +! Usage: As for the standard FORTRAN GETENV subroutine. +! +! Purpose: some versions/installations of MPI do not transfer the environmental +! variables to slave processors, if these variables are set in the shell script +! from which mpirun is called. +! +! A.Liwo, 7/29/01 +! +#ifdef MPI + use MPI_data + include "mpif.h" +#endif +! implicit none + character*(*) :: string,var +#if defined(MYGETENV) && defined(MPI) +! include "DIMENSIONS.ZSCOPT" +! include "mpif.h" +! include "COMMON.MPI" +!el character*360 ucase +!el external ucase + character(len=360) :: string1(360),karta + character(len=240) :: home + integer i,n !,ilen +!el external ilen + call getenv("HOME",home) + open(99,file=home(:ilen(home))//"/.env",status="OLD",err=112) + do while (.true.) + read (99,end=111,err=111,'(a)') karta + do i=1,80 + string1(i)=" " + enddo + call split_string(karta,string1,80,n) + if (ucase(string1(1)(:ilen(string1(1)))).eq."SETENV" .and. & + string1(2)(:ilen(string1(2))).eq.string(:ilen(string)) ) then + var=string1(3) + print *,"Processor",me,": ",var(:ilen(var)),& + " assigned to ",string(:ilen(string)) + close(99) + return + endif + enddo + 111 print *,"Environment variable ",string(:ilen(string))," not set." + close(99) + return + 112 print *,"Error opening environment file!" +#else + call getenv(string,var) +#endif + return + end subroutine mygetenv +!----------------------------------------------------------------------------- +! readrtns.F +!----------------------------------------------------------------------------- + subroutine read_general_data(*) + + use control_data, only:indpdb,symetr + use energy_data, only:distchainmax +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! include "COMMON.TORSION" +! include "COMMON.INTERACT" +! include "COMMON.IOUNITS" +! include "COMMON.TIME1" +! include "COMMON.PROT" +! include "COMMON.PROTFILES" +! include "COMMON.CHAIN" +! include "COMMON.NAMES" +! include "COMMON.FFIELD" +! include "COMMON.ENEPS" +! include "COMMON.WEIGHTS" +! include "COMMON.FREE" +! include "COMMON.CONTROL" +! include "COMMON.ENERGIES" + character(len=800) :: controlcard + integer :: i,j,k,ii,n_ene_found + integer :: ind,itype1,itype2,itypf,itypsc,itypp +!el integer ilen +!el external ilen +!el character*16 ucase + character(len=16) :: key +!el external ucase + call card_concat(controlcard,.true.) + call readi(controlcard,"N_ENE",n_eneW,max_eneW) + if (n_eneW.gt.max_eneW) then + write (iout,*) "Error: parameter out of range: N_ENE",n_eneW,& + max_eneW + return 1 + endif + call readi(controlcard,"NPARMSET",nparmset,1) +!elwrite(iout,*)"in read_gen data" + separate_parset = index(controlcard,"SEPARATE_PARSET").gt.0 + call readi(controlcard,"IPARMPRINT",iparmprint,1) + write (iout,*) "PARMPRINT",iparmprint + if (nparmset.gt.max_parm) then + write (iout,*) "Error: parameter out of range: NPARMSET",& + nparmset, Max_Parm + return 1 + endif +!elwrite(iout,*)"in read_gen data" + call readi(controlcard,"MAXIT",maxit,5000) + call reada(controlcard,"FIMIN",fimin,1.0d-3) + call readi(controlcard,"ENSEMBLES",ensembles,0) + hamil_rep=index(controlcard,"HAMIL_REP").gt.0 + write (iout,*) "Number of energy parameter sets",nparmset + allocate(isampl(nparmset)) + call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) + write (iout,*) "MaxSlice",MaxSlice + call readi(controlcard,"NSLICE",nslice,1) +!elwrite(iout,*)"in read_gen data" + call flush(iout) + if (nslice.gt.MaxSlice) then + write (iout,*) "Error: parameter out of range: NSLICE",nslice,& + MaxSlice + return 1 + endif + write (iout,*) "Frequency of storing conformations",& + (isampl(i),i=1,nparmset) + write (iout,*) "Maxit",maxit," Fimin",fimin + call readi(controlcard,"NQ",nQ,1) + if (nQ.gt.MaxQ) then + write (iout,*) "Error: parameter out of range: NQ",nq,& + maxq + return 1 + endif + indpdb=0 + if (index(controlcard,"CLASSIFY").gt.0) indpdb=1 + call reada(controlcard,"DELTA",delta,1.0d-2) + call readi(controlcard,"EINICHECK",einicheck,2) + call reada(controlcard,"DELTRMS",deltrms,5.0d-2) + call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) + call readi(controlcard,"RESCALE",rescale_modeW,1) + check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 + call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) + call readi(controlcard,'SYM',symetr,1) + write (iout,*) "DISTCHAINMAX",distchainmax + write (iout,*) "delta",delta + write (iout,*) "einicheck",einicheck + write (iout,*) "rescale_mode",rescale_modeW + call flush(iout) + bxfile=index(controlcard,"BXFILE").gt.0 + cxfile=index(controlcard,"CXFILE").gt.0 + if (nslice .eq. 1 .and. .not.bxfile .and. .not.cxfile) & + bxfile=.true. + histfile=index(controlcard,"HISTFILE").gt.0 + histout=index(controlcard,"HISTOUT").gt.0 + entfile=index(controlcard,"ENTFILE").gt.0 + zscfile=index(controlcard,"ZSCFILE").gt.0 + with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 + write (iout,*) "with_dihed_constr ",with_dihed_constr + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + return + end subroutine read_general_data +!------------------------------------------------------------------------------ + subroutine read_efree(*) +! +! Read molecular data +! +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.CHAIN' +! include 'COMMON.HEADER' +! include 'COMMON.GEO' +! include 'COMMON.FREE' + character(len=320) :: controlcard !,ucase + integer :: iparm,ib,i,j,npars +!el integer ilen +!el external ilen + + if (hamil_rep) then + npars=1 + else + npars=nParmSet + endif + +! call alloc_wham_arrays +! allocate(nT_h(nParmSet)) +! allocate(replica(nParmSet)) +! allocate(umbrella(nParmSet)) +! allocate(read_iset(nParmSet)) +! allocate(nT_h(nParmSet)) + + do iparm=1,npars + + call card_concat(controlcard,.true.) + call readi(controlcard,'NT',nT_h(iparm),1) + write (iout,*) "iparm",iparm," nt",nT_h(iparm) + call flush(iout) + if (nT_h(iparm).gt.MaxT_h) then + write (iout,*) "Error: parameter out of range: NT",nT_h(iparm),& + MaxT_h + return 1 + endif + replica(iparm)=index(controlcard,"REPLICA").gt.0 + umbrella(iparm)=index(controlcard,"UMBRELLA").gt.0 + read_iset(iparm)=index(controlcard,"READ_ISET").gt.0 + write (iout,*) "nQ",nQ," nT",nT_h(iparm)," replica ",& + replica(iparm)," umbrella ",umbrella(iparm),& + " read_iset",read_iset(iparm) + call flush(iout) + do ib=1,nT_h(iparm) + call card_concat(controlcard,.true.) + call readi(controlcard,'NR',nR(ib,iparm),1) + if (umbrella(iparm)) then + nRR(ib,iparm)=1 + else + nRR(ib,iparm)=nR(ib,iparm) + endif + if (nR(ib,iparm).gt.MaxR) then + write (iout,*) "Error: parameter out of range: NR",& + nR(ib,iparm),MaxR + return 1 + endif + call reada(controlcard,'TEMP',beta_h(ib,iparm),298.0d0) + beta_h(ib,iparm)=1.0d0/(beta_h(ib,iparm)*1.987D-3) + call multreada(controlcard,'FI',f(1,ib,iparm),nR(ib,iparm),& + 0.0d0) + do i=1,nR(ib,iparm) + call card_concat(controlcard,.true.) + call multreada(controlcard,'KH',KH(1,i,ib,iparm),nQ,& + 100.0d0) + call multreada(controlcard,'Q0',Q0(1,i,ib,iparm),nQ,& + 0.0d0) + enddo + enddo + do ib=1,nT_h(iparm) + write (iout,*) "ib",ib," beta_h",& + 1.0d0/(0.001987*beta_h(ib,iparm)) + write (iout,*) "nR",nR(ib,iparm) + write (iout,*) "fi",(f(i,ib,iparm),i=1,nR(ib,iparm)) + do i=1,nR(ib,iparm) + write (iout,*) "i",i," Kh",(Kh(j,i,ib,iparm),j=1,nQ),& + "q0",(q0(j,i,ib,iparm),j=1,nQ) + enddo + call flush(iout) + enddo + + enddo + + if (hamil_rep) then + + do iparm=2,nParmSet + nT_h(iparm)=nT_h(1) + do ib=1,nT_h(iparm) + nR(ib,iparm)=nR(ib,1) + if (umbrella(iparm)) then + nRR(ib,iparm)=1 + else + nRR(ib,iparm)=nR(ib,1) + endif + beta_h(ib,iparm)=beta_h(ib,1) + do i=1,nR(ib,iparm) + f(i,ib,iparm)=f(i,ib,1) + do j=1,nQ + KH(j,i,ib,iparm)=KH(j,i,ib,1) + Q0(j,i,ib,iparm)=Q0(j,i,ib,1) + enddo + enddo + replica(iparm)=replica(1) + umbrella(iparm)=umbrella(1) + read_iset(iparm)=read_iset(1) + enddo + enddo + + endif + + return + end subroutine read_efree +!----------------------------------------------------------------------------- + subroutine read_protein_data(*) +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +#ifdef MPI + use MPI_data + include "mpif.h" + integer :: IERROR,ERRCODE!,STATUS(MPI_STATUS_SIZE) +! include "COMMON.MPI" +#endif +! include "COMMON.CHAIN" +! include "COMMON.IOUNITS" +! include "COMMON.PROT" +! include "COMMON.PROTFILES" +! include "COMMON.NAMES" +! include "COMMON.FREE" +! include "COMMON.OBCINKA" + character(len=64) :: nazwa + character(len=16000) :: controlcard + integer :: i,ii,ib,iR,iparm,nthr,npars !,ilen,iroof +!el external ilen,iroof + if (hamil_rep) then + npars=1 + else + npars=nparmset + endif + + do iparm=1,npars + +! Read names of files with conformation data. + if (replica(iparm)) then + nthr = 1 + else + nthr = nT_h(iparm) + endif + do ib=1,nthr + do ii=1,nRR(ib,iparm) + write (iout,*) "Parameter set",iparm," temperature",ib,& + " window",ii + call flush(iout) + call card_concat(controlcard,.true.) + write (iout,*) controlcard(:ilen(controlcard)) + call readi(controlcard,"NFILE_BIN",nfile_bin(ii,ib,iparm),0) + call readi(controlcard,"NFILE_ASC",nfile_asc(ii,ib,iparm),0) + call readi(controlcard,"NFILE_CX",nfile_cx(ii,ib,iparm),0) + call readi(controlcard,"REC_START",rec_start(ii,ib,iparm),1) + call readi(controlcard,"REC_END",rec_end(ii,ib,iparm),& + maxstr*isampl(iparm)+rec_start(ii,ib,iparm)-1) + call reada(controlcard,"TIME_START",& + time_start_collect(ii,ib,iparm),0.0d0) + call reada(controlcard,"TIME_END",time_end_collect(ii,ib,iparm),& + 1.0d10) + write (iout,*) "rec_start",rec_start(ii,ib,iparm),& + " rec_end",rec_end(ii,ib,iparm) + write (iout,*) "time_start",time_start_collect(ii,ib,iparm),& + " time_end",time_end_collect(ii,ib,iparm) + call flush(iout) + if (replica(iparm)) then + call readi(controlcard,"TOTRAJ",totraj(ii,iparm),1) + write (iout,*) "Number of trajectories",totraj(ii,iparm) + call flush(iout) + endif + if (nfile_bin(ii,ib,iparm).lt.2 & + .and. nfile_asc(ii,ib,iparm).eq.0 & + .and. nfile_cx(ii,ib,iparm).eq.0) then + write (iout,*) "Error - no action specified!" + return 1 + endif + if (nfile_bin(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,1,ii,ib,iparm),& + maxfile_prot,nfile_bin(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*)"nfile_bin",nfile_bin(ii,ib,iparm) + write(iout,*) (protfiles(i,1,ii,ib,iparm),& + i=1,nfile_bin(ii,ib,iparm)) +#endif + endif + if (nfile_asc(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,2,ii,ib,iparm),& + maxfile_prot,nfile_asc(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*) "nfile_asc(ii,ib,iparm)",nfile_asc(ii,ib,iparm) + write(iout,*) (protfiles(i,2,ii,ib,iparm),& + i=1,nfile_asc(ii,ib,iparm)) +#endif + else if (nfile_cx(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,2,ii,ib,iparm),& + maxfile_prot,nfile_cx(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*) "nfile_cx(ii,ib,iparm)",nfile_cx(ii,ib,iparm) + write(iout,*) (protfiles(i,2,ii,ib,iparm),& + i=1,nfile_cx(ii,ib,iparm)) +#endif + endif + call flush(iout) + enddo + enddo + + enddo + return + end subroutine read_protein_data +!------------------------------------------------------------------------------- + subroutine readsss(rekord,lancuch,wartosc,default) +! implicit none + character*(*) :: rekord,lancuch,wartosc,default + character(len=80) :: aux + integer :: lenlan,lenrec,iread,ireade +!el external ilen +!el logical iblnk +!el external iblnk + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +! print *,"rekord",rekord," lancuch",lancuch +! print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+lenlan+1 +! print *,"iread",iread +! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +! print *,"iread",iread + if (iread.gt.lenrec) then + wartosc=default + return + endif + ireade=iread+1 +! print *,"ireade",ireade + do while (ireade.lt.lenrec .and. & + .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + wartosc=rekord(iread:ireade) + return + end subroutine readsss +!---------------------------------------------------------------------------- + subroutine multreads(rekord,lancuch,tablica,dim,default) +! implicit none + integer :: dim,i + character*(*) rekord,lancuch,tablica(dim),default + character(len=80) :: aux + integer :: lenlan,lenrec,iread,ireade +!el external ilen +!el logical iblnk +!el external iblnk + do i=1,dim + tablica(i)=default + enddo + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +! print *,"rekord",rekord," lancuch",lancuch +! print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) return + iread=iread+lenlan+1 + do i=1,dim +! print *,"iread",iread +! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +! print *,"iread",iread + if (iread.gt.lenrec) return + ireade=iread+1 +! print *,"ireade",ireade + do while (ireade.lt.lenrec .and. & + .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + tablica(i)=rekord(iread:ireade) + iread=ireade+1 + enddo + end subroutine multreads +!---------------------------------------------------------------------------- + subroutine split_string(rekord,tablica,dim,nsub) +! implicit none + integer :: dim,nsub,i,ii,ll,kk + character*(*) tablica(dim) + character*(*) rekord +!el integer ilen +!el external ilen + do i=1,dim + tablica(i)=" " + enddo + ii=1 + ll = ilen(rekord) + nsub=0 + do i=1,dim +! Find the start of term name + kk = 0 + do while (ii.le.ll .and. rekord(ii:ii).eq." ") + ii = ii+1 + enddo +! Parse the name into TABLICA(i) until blank found + do while (ii.le.ll .and. rekord(ii:ii).ne." ") + kk = kk+1 + tablica(i)(kk:kk)=rekord(ii:ii) + ii = ii+1 + enddo + if (kk.gt.0) nsub=nsub+1 + if (ii.gt.ll) return + enddo + return + end subroutine split_string +!-------------------------------------------------------------------------------- +! readrtns_compar.F +!-------------------------------------------------------------------------------- + subroutine read_compar +! +! Read molecular data +! + use conform_compar, only:alloc_compar_arrays + use control_data, only:pdbref + use geometry_data, only:deg2rad,rad2deg +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! include 'DIMENSIONS.FREE' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.SBRIDGE' +! include 'COMMON.CONTROL' +! include 'COMMON.COMPAR' +! include 'COMMON.CHAIN' +! include 'COMMON.HEADER' +! include 'COMMON.GEO' +! include 'COMMON.FREE' + character(len=320) :: controlcard !,ucase + character(len=64) :: wfile +!el integer ilen +!el external ilen + integer :: i,j,k +!elwrite(iout,*)"jestesmy w read_compar" + call card_concat(controlcard,.true.) + pdbref=(index(controlcard,'PDBREF').gt.0) + call reada(controlcard,'CUTOFF_UP',rmscut_base_up,4.0d0) + call reada(controlcard,'CUTOFF_LOW',rmscut_base_low,3.0d0) + call reada(controlcard,'RMSUP_LIM',rmsup_lim,4.0d0) + call reada(controlcard,'RMSUPUP_LIM',rmsupup_lim,7.5d0) + verbose = index(controlcard,"VERBOSE").gt.0 + lgrp=index(controlcard,"STATIN").gt.0 + lgrp_out=index(controlcard,"STATOUT").gt.0 + merge_helices=index(controlcard,"DONT_MERGE_HELICES").eq.0 + binary = index(controlcard,"BINARY").gt.0 + rmscut_base_up=rmscut_base_up/50 + rmscut_base_low=rmscut_base_low/50 + call reada(controlcard,"FRAC_SEC",frac_sec,0.66666666d0) + call readi(controlcard,'NLEVEL',nlevel,1) + if (nlevel.lt.0) then + allocate(nfrag(2)) + call alloc_compar_arrays(maxfrag,1) + goto 121 + else + allocate(nfrag(nlevel)) + endif +! Read the data pertaining to elementary fragments (level 1) + call readi(controlcard,'NFRAG',nfrag(1),0) + write(iout,*)"nfrag(1)",nfrag(1) + call alloc_compar_arrays(nfrag(1),nlevel) + do j=1,nfrag(1) + call card_concat(controlcard,.true.) + write (iout,*) controlcard(:ilen(controlcard)) + call readi(controlcard,'NPIECE',npiece(j,1),0) + call readi(controlcard,'N_SHIFT1',n_shift(1,j,1),0) + call readi(controlcard,'N_SHIFT2',n_shift(2,j,1),0) + call reada(controlcard,'ANGCUT',ang_cut(j),50.0d0) + call reada(controlcard,'MAXANG',ang_cut1(j),360.0d0) + call reada(controlcard,'FRAC_MIN',frac_min(j),0.666666d0) + call reada(controlcard,'NC_FRAC',nc_fragm(j,1),0.5d0) + call readi(controlcard,'NC_REQ',nc_req_setf(j,1),0) + call readi(controlcard,'RMS',irms(j,1),0) + call readi(controlcard,'LOCAL',iloc(j),1) + call readi(controlcard,'ELCONT',ielecont(j,1),1) + if (ielecont(j,1).eq.0) then + call readi(controlcard,'SCCONT',isccont(j,1),1) + endif + ang_cut(j)=ang_cut(j)*deg2rad + ang_cut1(j)=ang_cut1(j)*deg2rad + do k=1,npiece(j,1) + call card_concat(controlcard,.true.) + call readi(controlcard,'IFRAG1',ifrag(1,k,j),0) + call readi(controlcard,'IFRAG2',ifrag(2,k,j),0) + enddo + write(iout,*)"j",j," npiece",npiece(j,1)," ifrag",& + (ifrag(1,k,j),ifrag(2,k,j),& + k=1,npiece(j,1))," ang_cut",ang_cut(j)*rad2deg,& + " ang_cut1",ang_cut1(j)*rad2deg + write(iout,*)"n_shift",n_shift(1,j,1),n_shift(2,j,1) + write(iout,*)"nc_frac",nc_fragm(j,1)," nc_req",nc_req_setf(j,1) + write(iout,*)"irms",irms(j,1)," ielecont",ielecont(j,1),& + " ilocal",iloc(j)," isccont",isccont(j,1) + enddo +! Read data pertaning to higher levels + do i=2,nlevel + call card_concat(controlcard,.true.) + call readi(controlcard,'NFRAG',NFRAG(i),0) + write (iout,*) "i",i," nfrag",nfrag(i) + do j=1,nfrag(i) + call card_concat(controlcard,.true.) + if (i.eq.2) then + call readi(controlcard,'ELCONT',ielecont(j,i),0) + if (ielecont(j,i).eq.0) then + call readi(controlcard,'SCCONT',isccont(j,i),1) + endif + call readi(controlcard,'RMS',irms(j,i),0) + else + ielecont(j,i)=0 + isccont(j,i)=0 + irms(j,i)=1 + endif + call readi(controlcard,'NPIECE',npiece(j,i),0) + call readi(controlcard,'N_SHIFT1',n_shift(1,j,i),0) + call readi(controlcard,'N_SHIFT2',n_shift(2,j,i),0) + call multreadi(controlcard,'IPIECE',ipiece(1,j,i),& + npiece(j,i),0) + call reada(controlcard,'NC_FRAC',nc_fragm(j,i),0.5d0) + call readi(controlcard,'NC_REQ',nc_req_setf(j,i),0) + write(iout,*) "j",j," npiece",npiece(j,i)," n_shift",& + n_shift(1,j,i),n_shift(2,j,i)," ielecont",ielecont(j,i),& + " isccont",isccont(j,i)," irms",irms(j,i) + write(iout,*) "ipiece",(ipiece(k,j,i),k=1,npiece(j,i)) + write(iout,*)"n_shift",n_shift(1,j,i),n_shift(2,j,i) + write(iout,*)"nc_frac",nc_fragm(j,i),& + " nc_req",nc_req_setf(j,i) + enddo + enddo + if (binary) write (iout,*) "Classes written in binary format." + return + 121 continue + call reada(controlcard,'ANGCUT_HEL',angcut_hel,50.0d0) + call reada(controlcard,'MAXANG_HEL',angcut1_hel,60.0d0) + call reada(controlcard,'ANGCUT_BET',angcut_bet,90.0d0) + call reada(controlcard,'MAXANG_BET',angcut1_bet,360.0d0) + call reada(controlcard,'ANGCUT_STRAND',angcut_strand,90.0d0) + call reada(controlcard,'MAXANG_STRAND',angcut1_strand,60.0d0) + call reada(controlcard,'FRAC_MIN',frac_min_set,0.666666d0) + call reada(controlcard,'NC_FRAC_HEL',ncfrac_hel,0.5d0) + call readi(controlcard,'NC_REQ_HEL',ncreq_hel,0) + call reada(controlcard,'NC_FRAC_BET',ncfrac_bet,0.5d0) + call reada(controlcard,'NC_FRAC_PAIR',ncfrac_pair,0.3d0) + call readi(controlcard,'NC_REQ_BET',ncreq_bet,0) + call readi(controlcard,'NC_REQ_PAIR',ncreq_pair,0) + call readi(controlcard,'NSHIFT_HEL',nshift_hel,3) + call readi(controlcard,'NSHIFT_BET',nshift_bet,3) + call readi(controlcard,'NSHIFT_STRAND',nshift_strand,3) + call readi(controlcard,'NSHIFT_PAIR',nshift_pair,3) + call readi(controlcard,'RMS_SINGLE',irms_single,0) + call readi(controlcard,'CONT_SINGLE',icont_single,1) + call readi(controlcard,'LOCAL_SINGLE',iloc_single,1) + call readi(controlcard,'RMS_PAIR',irms_pair,0) + call readi(controlcard,'CONT_PAIR',icont_pair,1) + call readi(controlcard,'SPLIT_BET',isplit_bet,0) + angcut_hel=angcut_hel*deg2rad + angcut1_hel=angcut1_hel*deg2rad + angcut_bet=angcut_bet*deg2rad + angcut1_bet=angcut1_bet*deg2rad + angcut_strand=angcut_strand*deg2rad + angcut1_strand=angcut1_strand*deg2rad + write (iout,*) "Automatic detection of structural elements" + write (iout,*) 'NC_FRAC_HEL',ncfrac_hel,' NC_REQ_HEL',ncreq_hel,& + ' NC_FRAC_BET',ncfrac_bet,' NC_REQ_BET',ncreq_bet,& + ' RMS_SINGLE',irms_single,' CONT_SINGLE',icont_single,& + ' NC_FRAC_PAIR',ncfrac_pair,' NC_REQ_PAIR',ncreq_pair,& + ' RMS_PAIR',irms_pair,' CONT_PAIR',icont_pair,& + ' SPLIT_BET',isplit_bet + write (iout,*) 'NSHIFT_HEL',nshift_hel,' NSHIFT_BET',nshift_bet,& + ' NSHIFT_STRAND',nshift_strand,' NSHIFT_PAIR',nshift_pair + write (iout,*) 'ANGCUT_HEL',angcut_hel*rad2deg,& + ' MAXANG_HEL',angcut1_hel*rad2deg + write (iout,*) 'ANGCUT_BET',angcut_bet*rad2deg,& + ' MAXANG_BET',angcut1_bet*rad2deg + write (iout,*) 'ANGCUT_STRAND',angcut_strand*rad2deg,& + ' MAXANG_STRAND',angcut1_strand*rad2deg + write (iout,*) 'FRAC_MIN',frac_min_set + return + end subroutine read_compar +!-------------------------------------------------------------------------------- +! read_ref_str.F +!-------------------------------------------------------------------------------- + subroutine read_ref_structure(*) +! +! Read the reference structure from the PDB file or from a PDB file or in the form of the dihedral +! angles. +! + use control_data, only:pdbref + use geometry_data, only:nres,cref,c,dc,nsup,dc_norm,nend_sup,& + nstart_sup,nstart_seq,nperm,nres0 + use energy_data, only:nct,nnt,icont_ref,ncont_ref,itype + use compare, only:seq_comp !,contact,elecont + use geometry, only:chainbuild,dist + use io_config, only:readpdb +! + use conform_compar, only:contact,elecont +! implicit none +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'DIMENSIONS.COMPAR' +! 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.CONTACTS1' +! include 'COMMON.PEPTCONT' +! include 'COMMON.TIME1' +! include 'COMMON.COMPAR' + character(len=4) :: sequence(nres) +!el integer rescode +!el real(kind=8) :: x(maxvar) + integer :: itype_pdb(nres) +!el logical seq_comp + integer :: i,j,k,nres_pdb,iaux + real(kind=8) :: ddsc !el,dist + integer :: kkk !,ilen +!el external ilen +! + nres0=nres + write (iout,*) "pdbref",pdbref + if (pdbref) then + read(inp,'(a)') pdbfile + write (iout,'(2a,1h.)') 'PDB data will be read from file ',& + pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a)') 'Error opening PDB file.' + return 1 + 34 continue + do i=1,nres + itype_pdb(i)=itype(i) + enddo + + call readpdb + + do i=1,nres + iaux=itype_pdb(i) + itype_pdb(i)=itype(i) + itype(i)=iaux + enddo + close (ipdbin) + do kkk=1,nperm + nres_pdb=nres + nres=nres0 + nstart_seq=nnt + if (nsup.le.(nct-nnt+1)) then + do i=0,nct-nnt+1-nsup + if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),& + nsup)) then + do j=nnt+nsup-1,nnt,-1 + do k=1,3 + cref(k,nres+j+i,kkk)=cref(k,nres_pdb+j,kkk) + enddo + enddo + do j=nnt+nsup-1,nnt,-1 + do k=1,3 + cref(k,j+i,kkk)=cref(k,j,kkk) + enddo + phi_ref(j+i)=phi_ref(j) + theta_ref(j+i)=theta_ref(j) + alph_ref(j+i)=alph_ref(j) + omeg_ref(j+i)=omeg_ref(j) + enddo +#ifdef DEBUG + do j=nnt,nct + write (iout,'(i5,3f10.5,5x,3f10.5)') & + j,(cref(k,j,kkk),k=1,3),(cref(k,j+nres,kkk),k=1,3) + enddo +#endif + nstart_seq=nnt+i + nstart_sup=nnt+i + goto 111 + endif + enddo + write (iout,'(a)') & + 'Error - sequences to be superposed do not match.' + return 1 + else + do i=0,nsup-(nct-nnt+1) + if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),& + nct-nnt+1)) & + then + nstart_sup=nstart_sup+i + nsup=nct-nnt+1 + goto 111 + endif + enddo + write (iout,'(a)') & + 'Error - sequences to be superposed do not match.' + endif + enddo + 111 continue + write (iout,'(a,i5)') & + 'Experimental structure begins at residue',nstart_seq + else + call read_angles(inp,*38) + goto 39 + 38 write (iout,'(a)') 'Error reading reference structure.' + return 1 + 39 call chainbuild + kkk=1 + nstart_sup=nnt + nstart_seq=nnt + nsup=nct-nnt+1 + do i=1,2*nres + do j=1,3 + cref(j,i,kkk)=c(j,i) + enddo + enddo + endif + nend_sup=nstart_sup+nsup-1 + do i=1,2*nres + do j=1,3 + c(j,i)=cref(j,i,kkk) + enddo + enddo + do i=1,nres + do j=1,3 + dc(j,nres+i)=cref(j,nres+i,kkk)-cref(j,i,kkk) + enddo + if (itype(i).ne.10) then + ddsc = dist(i,nres+i) + do j=1,3 + dc_norm(j,nres+i)=dc(j,nres+i)/ddsc + enddo + else + do j=1,3 + dc_norm(j,nres+i)=0.0d0 + enddo + endif +! write (iout,*) "i",i," dc_norm",(dc_norm(k,nres+i),k=1,3), +! " norm",dc_norm(1,nres+i)**2+dc_norm(2,nres+i)**2+ +! dc_norm(3,nres+i)**2 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + enddo + ddsc = dist(i,i+1) + do j=1,3 + dc_norm(j,i)=dc(j,i)/ddsc + enddo + enddo +! print *,"Calling contact" + call contact(.true.,ncont_ref,icont_ref(1,1),& + nstart_sup,nend_sup) +! print *,"Calling elecont" + call elecont(.true.,ncont_pept_ref,& + icont_pept_ref(1,1),& + nstart_sup,nend_sup) + write (iout,'(a,i3,a,i3,a,i3,a)') & + 'Number of residues to be superposed:',nsup,& + ' (from residue',nstart_sup,' to residue',& + nend_sup,').' + return + end subroutine read_ref_structure +!-------------------------------------------------------------------------------- +! geomout.F +!-------------------------------------------------------------------------------- + subroutine pdboutW(ii,temp,efree,etot,entropy,rmsdev) + + use geometry_data, only:nres,c + use energy_data, only:nss,nnt,nct,ihpb,jhpb,itype +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'DIMENSIONS.ZSCOPT' +! include 'COMMON.CHAIN' +! include 'COMMON.INTERACT' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' +! include 'COMMON.HEADER' +! include 'COMMON.SBRIDGE' + character(len=50) :: tytul + character(len=1),dimension(10) :: chainid=reshape((/'A','B','C',& + 'D','E','F','G','H','I','J'/),shape(chainid)) + integer,dimension(nres) :: ica !(maxres) + real(kind=8) :: temp,efree,etot,entropy,rmsdev + integer :: ii,i,j,iti,ires,iatom,ichain + write(ipdb,'("REMARK CONF",i8," TEMPERATURE",f7.1," RMS",0pf7.2)')& + ii,temp,rmsdev + write (ipdb,'("REMARK DIMENSIONLESS FREE ENERGY",1pe15.5)') & + efree + write (ipdb,'("REMARK ENERGY",1pe15.5," ENTROPY",1pe15.5)') & + etot,entropy + iatom=0 + ichain=1 + ires=0 + do i=nnt,nct + iti=itype(i) + if (iti.eq.ntyp1) then + ichain=ichain+1 + ires=0 + write (ipdb,'(a)') 'TER' + else + ires=ires+1 + iatom=iatom+1 + ica(i)=iatom + write (ipdb,10) iatom,restyp(iti),chainid(ichain),& + ires,(c(j,i),j=1,3) + if (iti.ne.10) then + iatom=iatom+1 + write (ipdb,20) iatom,restyp(iti),chainid(ichain),& + ires,(c(j,nres+i),j=1,3) + endif + endif + enddo + write (ipdb,'(a)') 'TER' + do i=nnt,nct-1 + if (itype(i).eq.ntyp1) cycle + if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then + write (ipdb,30) ica(i),ica(i+1) + else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then + write (ipdb,30) ica(i),ica(i+1),ica(i)+1 + else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then + write (ipdb,30) ica(i),ica(i)+1 + endif + enddo + if (itype(nct).ne.10) then + write (ipdb,30) ica(nct),ica(nct)+1 + endif + do i=1,nss + write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 + enddo + write (ipdb,'(a6)') 'ENDMDL' + 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3) + 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,f15.3) + 30 FORMAT ('CONECT',8I5) + return + end subroutine pdboutW +#endif +!------------------------------------------------------------------------------ + end module io_wham +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + diff --git a/source/wham/io_wham.f90 b/source/wham/io_wham.f90 deleted file mode 100644 index 23530b6..0000000 --- a/source/wham/io_wham.f90 +++ /dev/null @@ -1,2765 +0,0 @@ - module io_wham - - use io_units - use io_base - use wham_data -#ifndef CLUSTER - use w_compar_data -#endif -! use geometry_data -! use geometry - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! openunits.F -!----------------------------------------------------------------------------- -#ifndef CLUSTER - subroutine openunits -#ifdef WIN - use dfport -#endif -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -#ifdef MPI - use MPI_data - include 'mpif.h' -! include 'COMMON.MPI' -! integer :: MyRank - character(len=3) :: liczba -#endif -! include 'COMMON.IOUNITS' - integer :: lenpre,lenpot !,ilen -!el external ilen - -#ifdef MPI - MyRank=Me -#endif - call mygetenv('PREFIX',prefix) - call mygetenv('SCRATCHDIR',scratchdir) - call mygetenv('POT',pot) - lenpre=ilen(prefix) - lenpot=ilen(pot) - call mygetenv('POT',pot) - entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' -! Get the names and open the input files - open (1,file=prefix(:ilen(prefix))//'.inp',status='old') -! Get parameter filenames and open the parameter files. - call mygetenv('BONDPAR',bondname) - open (ibond,file=bondname,status='old') - call mygetenv('THETPAR',thetname) - open (ithep,file=thetname,status='old') - call mygetenv('ROTPAR',rotname) - open (irotam,file=rotname,status='old') - call mygetenv('TORPAR',torname) - open (itorp,file=torname,status='old') - call mygetenv('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call mygetenv('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call mygetenv('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call mygetenv('ELEPAR',elename) - open (ielep,file=elename,status='old') - call mygetenv('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') - call mygetenv('SIDEP',sidepname) - open (isidep1,file=sidepname,status="old") -#ifndef OLDSCP -! -! 8/9/01 In the newest version SCp interaction constants are read from a file -! Use -DOLDSCP to use hard-coded constants instead. -! - call mygetenv('SCPPAR',scpname) - open (iscpp,file=scpname,status='old') -#endif -#ifdef MPL - if (MyID.eq.BossID) then - MyRank = MyID/fgProcs -#endif -#ifdef MPI - print *,'OpenUnits: processor',MyRank - call numstr(MyRank,liczba) - outname=prefix(:lenpre)//'.out_'//pot(:lenpot)//liczba -#else - outname=prefix(:lenpre)//'.out_'//pot(:lenpot) -#endif - open(iout,file=outname,status='unknown') - write (iout,'(80(1h-))') - write (iout,'(30x,a)') "FILE ASSIGNMENT" - write (iout,'(80(1h-))') - write (iout,*) "Input file : ",& - prefix(:ilen(prefix))//'.inp' - write (iout,*) "Output file : ",& - outname(:ilen(outname)) - write (iout,*) - write (iout,*) "Sidechain potential file : ",& - sidename(:ilen(sidename)) -#ifndef OLDSCP - write (iout,*) "SCp potential file : ",& - scpname(:ilen(scpname)) -#endif - write (iout,*) "Electrostatic potential file : ",& - elename(:ilen(elename)) - write (iout,*) "Cumulant coefficient file : ",& - fouriername(:ilen(fouriername)) - write (iout,*) "Torsional parameter file : ",& - torname(:ilen(torname)) - write (iout,*) "Double torsional parameter file : ",& - tordname(:ilen(tordname)) - write (iout,*) "Backbone-rotamer parameter file : ",& - sccorname(:ilen(sccorname)) - write (iout,*) "Bond & inertia constant file : ",& - bondname(:ilen(bondname)) - write (iout,*) "Bending parameter file : ",& - thetname(:ilen(thetname)) - write (iout,*) "Rotamer parameter file : ",& - rotname(:ilen(rotname)) - write (iout,'(80(1h-))') - write (iout,*) - return - end subroutine openunits -!----------------------------------------------------------------------------- -! molread_zs.F -!----------------------------------------------------------------------------- - subroutine molread(*) -! -! Read molecular data. -! - use energy_data - use geometry_data, only:nres,deg2rad,c,dc - use control_data, only:iscode - use control, only:rescode,setup_var,init_int_table - use geometry, only:alloc_geo_arrays - use energy, only:alloc_ener_arrays -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! 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.TORCNSTR' -! include 'COMMON.CONTROL' - character(len=4),dimension(:),allocatable :: sequence !(nres) -!el integer :: rescode -!el real(kind=8) :: x(maxvar) - character(len=320) :: controlcard !,ucase - integer,dimension(nres) :: itype_pdb !(maxres) - integer :: i,j,i1,i2,it1,it2 - real(kind=8) :: scalscp -!el logical :: seq_comp - call card_concat(controlcard,.true.) - call reada(controlcard,'SCAL14',scal14,0.4d0) - call reada(controlcard,'SCALSCP',scalscp,1.0d0) - call reada(controlcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(controlcard,'TEMP0',temp0,300.0d0) !el - call reada(controlcard,'DELT_CORR',delt_corr,0.5d0) - r0_corr=cutoff_corr-delt_corr - call readi(controlcard,"NRES",nres,0) - allocate(sequence(nres+1)) -!el znamy juz ilosc reszt wiec mozna zaalokowac tablice do liczenia enerii - call alloc_geo_arrays - call alloc_ener_arrays -! alokacja dodatkowych tablic, ktore w unresie byly alokowanie w locie -!---------------------------- - allocate(c(3,2*nres+2)) - allocate(dc(3,0:2*nres+2)) - allocate(itype(nres+2)) - allocate(itel(nres+2)) -! -! Zero out tableis. - do i=1,2*nres+2 - do j=1,3 - c(j,i)=0.0D0 - dc(j,i)=0.0D0 - enddo - enddo - do i=1,nres+2 - itype(i)=0 - itel(i)=0 - enddo -!-------------------------- -! - iscode=index(controlcard,"ONE_LETTER") - if (nres.le.0) then - write (iout,*) "Error: no residues in molecule" - return 1 - endif - if (nres.gt.maxres) then - write (iout,*) "Error: too many residues",nres,maxres - endif - write(iout,*) 'nres=',nres -! Read sequence of the protein - if (iscode.gt.0) then - read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) - else - read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) - endif -! Convert sequence to numeric code - do i=1,nres - itype(i)=rescode(i,sequence(i),iscode) - enddo - write (iout,*) "Numeric code:" - write (iout,'(20i4)') (itype(i),i=1,nres) - do i=1,nres-1 -#ifdef PROCOR - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then -#else - if (itype(i).eq.ntyp1) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (iabs(itype(i+1)).ne.20) then -#else - else if (iabs(itype(i)).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - write (iout,*) "ITEL" - do i=1,nres-1 - write (iout,*) i,itype(i),itel(i) - enddo - call read_bridge - - if (with_dihed_constr) then - - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - read (inp,*) ftors - write (iout,*) 'FTORS',ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - write (iout,*) & - 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - endif - - endif - - nnt=1 - nct=nres - if (itype(1).eq.ntyp1) nnt=2 - if (itype(nres).eq.ntyp1) nct=nct-1 - write(iout,*) 'NNT=',NNT,' NCT=',NCT - call setup_var - call init_int_table - if (ns.gt.0) then - write (iout,'(/a,i3,a)') 'The chain contains',ns,& - ' disulfide-bridging cysteines.' - write (iout,'(20i4)') (iss(i),i=1,ns) - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - write (iout,'(2a,i3,3a,i3,a,3f10.3)') & - restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',& - dhpb(i),ebr,forcon(i) - enddo - endif - write (iout,'(a)') - return - end subroutine molread -!----------------------------------------------------------------------------- -! parmread.F -!----------------------------------------------------------------------------- - subroutine parmread(iparm,*) -#else - subroutine parmread -#endif -! -! Read the parameters of the probability distributions of the virtual-bond -! valence angles and the side chains and energy parameters. -! - use wham_data - - use geometry_data - use energy_data - use control_data, only: maxtor,maxterm,maxlor,maxterm_sccor,& - maxtermd_1,maxtermd_2,maxthetyp,maxthetyp1 - use MD_data -!el use MPI_data -!el use map_data - use io_config, only: printmat - use control, only: getenv_loc - -#ifdef MPI - use MPI_data - include "mpif.h" - integer :: IERROR -#endif -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' -! include 'COMMON.TORSION' -! include 'COMMON.FFIELD' -! include 'COMMON.NAMES' -! include 'COMMON.SBRIDGE' -! include 'COMMON.WEIGHTS' -! include 'COMMON.ENEPS' -! include 'COMMON.SCCOR' -! include 'COMMON.SCROT' -! include 'COMMON.FREE' - character(len=1) :: t1,t2,t3 - character(len=1) :: onelett(4) = (/"G","A","P","D"/) - character(len=1) :: toronelet(-2:2) = (/"p","a","G","A","P"/) - logical :: lprint - real(kind=8),dimension(3,3,maxlob) :: blower !(3,3,maxlob) - character(len=800) :: controlcard - character(len=256) :: bondname_t,thetname_t,rotname_t,torname_t,& - tordname_t,fouriername_t,elename_t,sidename_t,scpname_t,& - sccorname_t -!el integer ilen -!el external ilen - character(len=16) :: key - integer :: iparm -!el real(kind=8) :: ip,mp - real(kind=8) :: dwa16,akl,si,rri,epsij,rrij,sigeps,sigt1sq,& - sigt2sq,sigii1,sigii2,ratsig1,ratsig2,rsum_max,r_augm - real(kind=8) :: v0ij,v0ijsccor,v0ijsccor1,v0ijsccor2,v0ijsccor3,rjunk,& - res1 - integer :: i,j,ichir1,ichir2,k,l,m,kk,ii,mm,junk,lll,ll,llll,n - integer :: nlobi,iblock,maxinter,iscprol -! -! Body -! -! Set LPRINT=.TRUE. for debugging - dwa16=2.0d0**(1.0d0/6.0d0) - lprint=.false. - itypro=20 -! Assign virtual-bond length - vbl=3.8D0 - vblinv=1.0D0/vbl - vblinv2=vblinv*vblinv -#ifndef CLUSTER - call card_concat(controlcard,.true.) - wname(4)="WCORRH" -!el -allocate(ww(max_eneW)) - do i=1,n_eneW - key = wname(i)(:ilen(wname(i))) - call reada(controlcard,key(:ilen(key)),ww(i),1.0d0) - enddo - - write (iout,*) "iparm",iparm," myparm",myparm -! If reading not own parameters, skip assignment - - if (iparm.eq.myparm .or. .not.separate_parset) then - -! -! Setup weights for UNRES -! - wsc=ww(1) - wscp=ww(2) - welec=ww(3) - wcorr=ww(4) - wcorr5=ww(5) - wcorr6=ww(6) - wel_loc=ww(7) - wturn3=ww(8) - wturn4=ww(9) - wturn6=ww(10) - wang=ww(11) - wscloc=ww(12) - wtor=ww(13) - wtor_d=ww(14) - wvdwpp=ww(16) - wbond=ww(18) - wsccor=ww(19) - - endif -! -!el------ - allocate(weights(n_ene)) - weights(1)=wsc - weights(2)=wscp - weights(3)=welec - weights(4)=wcorr - weights(5)=wcorr5 - weights(6)=wcorr6 - weights(7)=wel_loc - weights(8)=wturn3 - weights(9)=wturn4 - weights(10)=wturn6 - weights(11)=wang - weights(12)=wscloc - weights(13)=wtor - weights(14)=wtor_d - weights(15)=0 !wstrain ! - weights(16)=0 !wvdwpp ! - weights(17)=wbond - weights(18)=0 !scal14 ! - weights(21)=wsccor -! el-------- - call card_concat(controlcard,.false.) - -! Return if not own parameters - - if (iparm.ne.myparm .and. separate_parset) return - - call reads(controlcard,"BONDPAR",bondname_t,bondname) - open (ibond,file=bondname_t,status='old') - rewind(ibond) - call reads(controlcard,"THETPAR",thetname_t,thetname) - open (ithep,file=thetname_t,status='old') - rewind(ithep) - call reads(controlcard,"ROTPAR",rotname_t,rotname) - open (irotam,file=rotname_t,status='old') - rewind(irotam) - call reads(controlcard,"TORPAR",torname_t,torname) - open (itorp,file=torname_t,status='old') - rewind(itorp) - call reads(controlcard,"TORDPAR",tordname_t,tordname) - open (itordp,file=tordname_t,status='old') - rewind(itordp) - call reads(controlcard,"SCCORPAR",sccorname_t,sccorname) - open (isccor,file=sccorname_t,status='old') - rewind(isccor) - call reads(controlcard,"FOURIER",fouriername_t,fouriername) - open (ifourier,file=fouriername_t,status='old') - rewind(ifourier) - call reads(controlcard,"ELEPAR",elename_t,elename) - open (ielep,file=elename_t,status='old') - rewind(ielep) - call reads(controlcard,"SIDEPAR",sidename_t,sidename) - open (isidep,file=sidename_t,status='old') - rewind(isidep) - call reads(controlcard,"SCPPAR",scpname_t,scpname) - open (iscpp,file=scpname_t,status='old') - rewind(iscpp) - write (iout,*) "Parameter set:",iparm - write (iout,*) "Energy-term weights:" - do i=1,n_eneW - write (iout,'(a16,f10.5)') wname(i),ww(i) - enddo - write (iout,*) "Sidechain potential file : ",& - sidename_t(:ilen(sidename_t)) -#ifndef OLDSCP - write (iout,*) "SCp potential file : ",& - scpname_t(:ilen(scpname_t)) -#endif - write (iout,*) "Electrostatic potential file : ",& - elename_t(:ilen(elename_t)) - write (iout,*) "Cumulant coefficient file : ",& - fouriername_t(:ilen(fouriername_t)) - write (iout,*) "Torsional parameter file : ",& - torname_t(:ilen(torname_t)) - write (iout,*) "Double torsional parameter file : ",& - tordname_t(:ilen(tordname_t)) - write (iout,*) "Backbone-rotamer parameter file : ",& - sccorname(:ilen(sccorname)) - write (iout,*) "Bond & inertia constant file : ",& - bondname_t(:ilen(bondname_t)) - write (iout,*) "Bending parameter file : ",& - thetname_t(:ilen(thetname_t)) - write (iout,*) "Rotamer parameter file : ",& - rotname_t(:ilen(rotname_t)) -#endif -! -! Read the virtual-bond parameters, masses, and moments of inertia -! and Stokes' radii of the peptide group and side chains -! - allocate(dsc(ntyp1)) !(ntyp1) - allocate(dsc_inv(ntyp1)) !(ntyp1) - allocate(nbondterm(ntyp)) !(ntyp) - allocate(vbldsc0(maxbondterm,ntyp)) !(maxbondterm,ntyp) - allocate(aksc(maxbondterm,ntyp)) !(maxbondterm,ntyp) -!el allocate(msc(ntyp+1)) !(ntyp+1) -!el allocate(isc(ntyp+1)) !(ntyp+1) -!el allocate(restok(ntyp+1)) !(ntyp+1) - allocate(abond0(maxbondterm,ntyp)) !(maxbondterm,ntyp) - -#ifdef CRYST_BOND - read (ibond,*) vbldp0,akp - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*) vbldsc0(1,i),aksc(1,i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#else - read (ibond,*) ijunk,vbldp0,akp,rjunk - do i=1,ntyp - read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i),& - j=1,nbondterm(i)) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#endif - if (lprint) then - write(iout,'(/a/)')"Force constants virtual bonds:" - write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K',& - 'inertia','Pstok' - write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0 - do i=1,ntyp - write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i),& - vbldsc0(1,i),aksc(1,i),abond0(1,i) - do j=2,nbondterm(i) - write (iout,'(13x,3f10.5)') & - vbldsc0(j,i),aksc(j,i),abond0(j,i) - enddo - enddo - endif -!---------------------------------------------------- - allocate(a0thet(-ntyp:ntyp),theta0(-ntyp:ntyp)) - allocate(sig0(-ntyp:ntyp),sigc0(-ntyp:ntyp)) !(-ntyp:ntyp) - allocate(athet(2,-ntyp:ntyp,-1:1,-1:1)) - allocate(bthet(2,-ntyp:ntyp,-1:1,-1:1)) !(2,-ntyp:ntyp,-1:1,-1:1) - allocate(polthet(0:3,-ntyp:ntyp)) !(0:3,-ntyp:ntyp) - allocate(gthet(3,-ntyp:ntyp)) !(3,-ntyp:ntyp) - do i=-ntyp,ntyp - 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 - enddo -!elwrite(iout,*) "parmread kontrol" - -#ifdef CRYST_THETA -! -! Read the parameters of the probability distribution/energy expression -! of the virtual-bond valence angles theta -! - do i=1,ntyp - read (ithep,*) a0thet(i),(athet(j,i,1,1),j=1,2),& - (bthet(j,i,1,1),j=1,2) - read (ithep,*) (polthet(j,i),j=0,3) -!elwrite(iout,*) "parmread kontrol in cryst_theta" - read (ithep,*) (gthet(j,i),j=1,3) -!elwrite(iout,*) "parmread kontrol in cryst_theta" - read (ithep,*) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 -!elwrite(iout,*) "parmread kontrol in cryst_theta" - enddo -!elwrite(iout,*) "parmread kontrol in cryst_theta" - do i=1,ntyp - athet(1,i,1,-1)=athet(1,i,1,1) - athet(2,i,1,-1)=athet(2,i,1,1) - bthet(1,i,1,-1)=-bthet(1,i,1,1) - bthet(2,i,1,-1)=-bthet(2,i,1,1) - athet(1,i,-1,1)=-athet(1,i,1,1) - athet(2,i,-1,1)=-athet(2,i,1,1) - bthet(1,i,-1,1)=bthet(1,i,1,1) - bthet(2,i,-1,1)=bthet(2,i,1,1) - enddo -!elwrite(iout,*) "parmread kontrol in cryst_theta" - do i=-ntyp,-1 - a0thet(i)=a0thet(-i) - athet(1,i,-1,-1)=athet(1,-i,1,1) - athet(2,i,-1,-1)=-athet(2,-i,1,1) - bthet(1,i,-1,-1)=bthet(1,-i,1,1) - bthet(2,i,-1,-1)=-bthet(2,-i,1,1) - athet(1,i,-1,1)=athet(1,-i,1,1) - athet(2,i,-1,1)=-athet(2,-i,1,1) - bthet(1,i,-1,1)=-bthet(1,-i,1,1) - bthet(2,i,-1,1)=bthet(2,-i,1,1) - athet(1,i,1,-1)=-athet(1,-i,1,1) - athet(2,i,1,-1)=athet(2,-i,1,1) - bthet(1,i,1,-1)=bthet(1,-i,1,1) - bthet(2,i,1,-1)=-bthet(2,-i,1,1) - theta0(i)=theta0(-i) - sig0(i)=sig0(-i) - sigc0(i)=sigc0(-i) - do j=0,3 - polthet(j,i)=polthet(j,-i) - enddo - do j=1,3 - gthet(j,i)=gthet(j,-i) - enddo - enddo -!elwrite(iout,*) "parmread kontrol in cryst_theta" - close (ithep) -!elwrite(iout,*) "parmread kontrol in cryst_theta" - if (lprint) then -! write (iout,'(a)') -! & 'Parameters of the virtual-bond valence angles:' -! write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', -! & ' ATHETA0 ',' A1 ',' A2 ', -! & ' B1 ',' B2 ' -! do i=1,ntyp -! write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, -! & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) -! enddo -! write (iout,'(/a/9x,5a/79(1h-))') -! & 'Parameters of the expression for sigma(theta_c):', -! & ' ALPH0 ',' ALPH1 ',' ALPH2 ', -! & ' ALPH3 ',' SIGMA0C ' -! do i=1,ntyp -! write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, -! & (polthet(j,i),j=0,3),sigc0(i) -! enddo -! write (iout,'(/a/9x,5a/79(1h-))') -! & 'Parameters of the second gaussian:', -! & ' THETA0 ',' SIGMA0 ',' G1 ', -! & ' G2 ',' G3 ' -! do i=1,ntyp -! write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), -! & sig0(i),(gthet(j,i),j=1,3) -! enddo - write (iout,'(a)') & - 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') & - 'Coefficients of expansion',& - ' theta0 ',' a1*10^2 ',' a2*10^2 ',& - ' b1*10^1 ',' b2*10^1 ' - do i=1,ntyp - write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),& - a0thet(i),(100*athet(j,i,1,1),j=1,2),& - (10*bthet(j,i,1,1),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') & - 'Parameters of the expression for sigma(theta_c):',& - ' alpha0 ',' alph1 ',' alph2 ',& - ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i),& - (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') & - 'Parameters of the second gaussian:',& - ' theta0 ',' sigma0*10^2 ',' G1*10^-1',& - ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i),& - 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif -#else -! -! Read the parameters of Utheta determined from ab initio surfaces -! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -! -! write (iout,*) "tu dochodze" - read (ithep,*) nthetyp,ntheterm,ntheterm2,& - ntheterm3,nsingle,ndouble - nntheterm=max0(ntheterm,ntheterm2,ntheterm3) - -!---------------------------------------------------- - allocate(ithetyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) - allocate(aa0thet(-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - allocate(aathet(ntheterm,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(maxtheterm,-maxthetyp1:maxthetyp1,& -! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - allocate(bbthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(ccthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(ddthet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(eethet(nsingle,ntheterm2,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,& -! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2) - allocate(ffthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - allocate(ggthet(ndouble,ndouble,ntheterm3,-maxthetyp1:maxthetyp1,& - -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) -!(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,& -! -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2)) - - - read (ithep,*) (ithetyp(i),i=1,ntyp1) - do i=-ntyp1,-1 - ithetyp(i)=-ithetyp(-i) - enddo -! write (iout,*) "tu dochodze" - do iblock=1,2 - do i=-maxthetyp,maxthetyp - do j=-maxthetyp,maxthetyp - do k=-maxthetyp,maxthetyp - aa0thet(i,j,k,iblock)=0.0d0 - do l=1,ntheterm - aathet(l,i,j,k,iblock)=0.0d0 - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k,iblock)=0.0d0 - ccthet(m,l,i,j,k,iblock)=0.0d0 - ddthet(m,l,i,j,k,iblock)=0.0d0 - eethet(m,l,i,j,k,iblock)=0.0d0 - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k,iblock)=0.0d0 - ggthet(mm,m,l,i,j,k,iblock)=0.0d0 - enddo - enddo - enddo - enddo - enddo - enddo - enddo - do iblock=1,2 - do i=0,nthetyp - do j=-nthetyp,nthetyp - do k=-nthetyp,nthetyp - read (ithep,'(6a)') res1 - read (ithep,*) aa0thet(i,j,k,iblock) - read (ithep,*)(aathet(l,i,j,k,iblock),l=1,ntheterm) - read (ithep,*) & - ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle),& - ll=1,ntheterm2) - read (ithep,*) & - (((ffthet(llll,lll,ll,i,j,k,iblock),& - ffthet(lll,llll,ll,i,j,k,iblock),& - ggthet(llll,lll,ll,i,j,k,iblock),& - ggthet(lll,llll,ll,i,j,k,iblock),& - llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -! -! For dummy ends assign glycine-type coefficients of theta-only terms; the -! coefficients of theta-and-gamma-dependent terms are zero. -! - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1,iblock)=0.0d0 - aathet(l,nthetyp+1,i,j,iblock)=0.0d0 - enddo - aa0thet(i,j,nthetyp+1,iblock)=0.0d0 - aa0thet(nthetyp+1,i,j,iblock)=0.0d0 - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 - enddo - aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 - enddo - enddo -! Substitution for D aminoacids from symmetry. - do iblock=1,2 - do i=-nthetyp,0 - do j=-nthetyp,nthetyp - do k=-nthetyp,nthetyp - aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock) - do l=1,ntheterm - aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock) - enddo - do ll=1,ntheterm2 - do lll=1,nsingle - bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock) - ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock) - ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock) - eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock) - enddo - enddo - do ll=1,ntheterm3 - do lll=2,ndouble - do llll=1,lll-1 - ffthet(llll,lll,ll,i,j,k,iblock)= & - ffthet(llll,lll,ll,-i,-j,-k,iblock) - ffthet(lll,llll,ll,i,j,k,iblock)= & - ffthet(lll,llll,ll,-i,-j,-k,iblock) - ggthet(llll,lll,ll,i,j,k,iblock)= & - -ggthet(llll,lll,ll,-i,-j,-k,iblock) - ggthet(lll,llll,ll,i,j,k,iblock)= & - -ggthet(lll,llll,ll,-i,-j,-k,iblock) - enddo !ll - enddo !lll - enddo !llll - enddo !k - enddo !j - enddo !i - enddo !iblock - -! -! Control printout of the coefficients of virtual-bond-angle potentials -! -do iblock=1,2 - if (lprint) then - write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' - do i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') & - 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) - write (iout,'(i2,1pe15.5)') & - (l,aathet(l,i,j,k,iblock),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') & - "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m,& - bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock),& - ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,i1,1h]))') & - "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m,& - ffthet(n,m,l,i,j,k,iblock),& - ffthet(m,n,l,i,j,k,iblock),& - ggthet(n,m,l,i,j,k,iblock),& - ggthet(m,n,l,i,j,k,iblock) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - endif -enddo -#endif -!------------------------------------------- - allocate(nlob(ntyp1)) !(ntyp1) - allocate(bsc(maxlob,ntyp)) !(maxlob,ntyp) - allocate(censc(3,maxlob,-ntyp:ntyp)) !(3,maxlob,-ntyp:ntyp) - allocate(gaussc(3,3,maxlob,-ntyp:ntyp)) !(3,3,maxlob,-ntyp:ntyp) - - do i=1,ntyp - do j=1,maxlob - bsc(j,i)=0.0D0 - nlob(i)=0 - enddo - enddo - nlob(ntyp1)=0 - dsc(ntyp1)=0.0D0 - - do i=-ntyp,ntyp - do j=1,maxlob - 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 - enddo - enddo - -#ifdef CRYST_SC -! -! Read the parameters of the probability distribution/energy expression -! of the side chains. -! - do i=1,ntyp -!c write (iout,*) "tu dochodze",i - read (irotam,'(3x,i3,f8.3)') nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*)(censc(k,1,i),k=1,3),((blower(k,l,1),l=1,k),k=1,3) - censc(1,1,-i)=censc(1,1,i) - censc(2,1,-i)=censc(2,1,i) - censc(3,1,-i)=-censc(3,1,i) - do j=2,nlob(i) - read (irotam,*) bsc(j,i) - read (irotam,*) (censc(k,j,i),k=1,3),& - ((blower(k,l,j),l=1,k),k=1,3) - censc(1,j,-i)=censc(1,j,i) - censc(2,j,-i)=censc(2,j,i) - censc(3,j,-i)=-censc(3,j,i) -! BSC is amplitude of Gaussian - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - if (((k.eq.3).and.(l.ne.3)) & - .or.((l.eq.3).and.(k.ne.3))) then - gaussc(k,l,j,-i)=-akl - gaussc(l,k,j,-i)=-akl - else - gaussc(k,l,j,-i)=akl - gaussc(l,k,j,-i)=akl - endif - enddo - enddo - enddo - endif - enddo - close (irotam) - if (lprint) then - write (iout,'(/a)') 'Parameters of side-chain local geometry' - do i=1,ntyp - nlobi=nlob(i) - if (nlobi.gt.0) then - write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i),& - ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) -! write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) -! write (iout,'(a,f10.4,4(16x,f10.4))') -! & 'Center ',(bsc(j,i),j=1,nlobi) -! write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3),j=1,nlobi) - write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') & - 'log h',(bsc(j,i),j=1,nlobi) - write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') & - 'x',((censc(k,j,i),k=1,3),j=1,nlobi) -! write (iout,'(a)') -! do j=1,nlobi -! ind=0 -! do k=1,3 -! do l=1,k -! ind=ind+1 -! blower(k,l,j)=gaussc(ind,j,i) -! enddo -! enddo -! enddo - do k=1,3 - write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') & - ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) - enddo - endif - enddo - endif -#else -! -! Read scrot parameters for potentials determined from all-atom AM1 calculations -! added by Urszula Kozlowska 07/11/2007 -! - allocate(sc_parmin(65,ntyp)) !(maxsccoef,ntyp) - - do i=1,ntyp - read (irotam,*) - if (i.eq.10) then - read (irotam,*) - else - do j=1,65 - read(irotam,*) sc_parmin(j,i) - enddo - endif - enddo -#endif - close(irotam) -#ifdef CRYST_TOR -! -! Read torsional parameters in old format -! - allocate(itortyp(ntyp1)) !(-ntyp1:ntyp1) - - read (itorp,*) ntortyp,nterm_old - write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old - read (itorp,*) (itortyp(i),i=1,ntyp) - -!el from energy module-------- - allocate(v1(nterm_old,ntortyp,ntortyp)) - allocate(v2(nterm_old,ntortyp,ntortyp)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor) -!el--------------------------- - - do i=1,ntortyp - do j=1,ntortyp - read (itorp,'(a)') - do k=1,nterm_old - read (itorp,*) kk,v1(k,j,i),v2(k,j,i) - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) - write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) - enddo - enddo - endif - - -#else -! -! Read torsional parameters -! - allocate(itortyp(-ntyp1:ntyp1)) !(-ntyp1:ntyp1) - - read (itorp,*) ntortyp - read (itorp,*) (itortyp(i),i=1,ntyp) - write (iout,*) 'ntortyp',ntortyp - -!el from energy module--------- - allocate(nterm(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) - allocate(nlor(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) - - allocate(vlor1(maxlor,-ntortyp:ntortyp,-ntortyp:ntortyp)) !(maxlor,-maxtor:maxtor,-maxtor:maxtor) - allocate(vlor2(maxlor,ntortyp,ntortyp)) - allocate(vlor3(maxlor,ntortyp,ntortyp)) !(maxlor,maxtor,maxtor) - allocate(v0(-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(-maxtor:maxtor,-maxtor:maxtor,2) - - allocate(v1(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) - allocate(v2(maxterm,-ntortyp:ntortyp,-ntortyp:ntortyp,2)) !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2) -!el--------------------------- - do iblock=1,2 - do i=-ntortyp,ntortyp - do j=-ntortyp,ntortyp - nterm(i,j,iblock)=0 - nlor(i,j,iblock)=0 - enddo - enddo - enddo -!el--------------------------- - - do iblock=1,2 - do i=-ntyp,-1 - itortyp(i)=-itortyp(-i) - enddo -! write (iout,*) 'ntortyp',ntortyp - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - read (itorp,*) nterm(i,j,iblock),& - nlor(i,j,iblock) - nterm(-i,-j,iblock)=nterm(i,j,iblock) - nlor(-i,-j,iblock)=nlor(i,j,iblock) - v0ij=0.0d0 - si=-1.0d0 - do k=1,nterm(i,j,iblock) - read (itorp,*) kk,v1(k,i,j,iblock),& - v2(k,i,j,iblock) - v1(k,-i,-j,iblock)=v1(k,i,j,iblock) - v2(k,-i,-j,iblock)=-v2(k,i,j,iblock) - v0ij=v0ij+si*v1(k,i,j,iblock) - si=-si - enddo - do k=1,nlor(i,j,iblock) - read (itorp,*) kk,vlor1(k,i,j),& - vlor2(k,i,j),vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j,iblock)=v0ij - v0(-i,-j,iblock)=v0ij - enddo - enddo - enddo - close (itorp) - if (lprint) then - do iblock=1,2 !el - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm(i,j,iblock) - write (iout,'(2(1pe15.5))') v1(k,i,j,iblock),& - v2(k,i,j,iblock) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j,iblock) - write (iout,'(3(1pe15.5))') & - vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - enddo - enddo - enddo - enddo - endif -! -! 6/23/01 Read parameters for double torsionals -! -!el from energy module------------ - allocate(v1c(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - allocate(v1s(2,maxtermd_1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) -!(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) - allocate(v2c(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - allocate(v2s(maxtermd_2,maxtermd_2,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) - allocate(ntermd_1(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - allocate(ntermd_2(-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,-ntortyp+1:ntortyp-1,2)) - !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) -!--------------------------------- - - do iblock=1,2 - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - do k=-ntortyp+1,ntortyp-1 - read (itordp,'(3a1)') t1,t2,t3 -! write (iout,*) "OK onelett", -! & i,j,k,t1,t2,t3 - - if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j) & - .or. t3.ne.toronelet(k)) then - write (iout,*) "Error in double torsional parameter file",& - i,j,k,t1,t2,t3 -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop "Error in double torsional parameter file" - endif - read (itordp,*) ntermd_1(i,j,k,iblock),& - ntermd_2(i,j,k,iblock) - ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock) - ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock) - read (itordp,*) (v1c(1,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) - read (itordp,*) (v1s(1,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) - read (itordp,*) (v1c(2,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) - read (itordp,*) (v1s(2,l,i,j,k,iblock),l=1,& - ntermd_1(i,j,k,iblock)) -! Martix of D parameters for one dimesional foureir series - do l=1,ntermd_1(i,j,k,iblock) - v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock) - v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock) - v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock) - v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock) -! write(iout,*) "whcodze" , -! & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock) - enddo - read (itordp,*) ((v2c(l,m,i,j,k,iblock),& - v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock),& - v2s(m,l,i,j,k,iblock),& - m=1,l-1),l=1,ntermd_2(i,j,k,iblock)) -! Martix of D parameters for two dimesional fourier series - do l=1,ntermd_2(i,j,k,iblock) - do m=1,l-1 - v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock) - v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock) - v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock) - v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock) - enddo!m - enddo!l - enddo!k - enddo!j - enddo!i - enddo!iblock - if (lprint) then - write (iout,*) - write (iout,*) 'Constants for double torsionals' - do iblock=1,2 - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - do k=-ntortyp+1,ntortyp-1 - write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,& - ' nsingle',ntermd_1(i,j,k,iblock),& - ' ndouble',ntermd_2(i,j,k,iblock) - write (iout,*) - write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k,iblock) - write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l,& - v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock),& - v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock),& - v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock) - enddo - write (iout,*) - write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) - do l=1,ntermd_2(i,j,k,iblock) - write (iout,'(i5,20f10.5)') & - l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)) - enddo - write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) - do l=1,ntermd_2(i,j,k,iblock) - write (iout,'(i5,20f10.5)') & - l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)),& - (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock)) - enddo - write (iout,*) - enddo - enddo - enddo - enddo - endif -#endif -!elwrite(iout,*) "parmread kontrol sc-bb" -! Read of Side-chain backbone correlation parameters -! Modified 11 May 2012 by Adasko -!CC -! - read (isccor,*) nsccortyp - - maxinter=3 -!c maxinter is maximum interaction sites -!write(iout,*)"maxterm_sccor",maxterm_sccor -!el from module energy------------- - allocate(nlor_sccor(nsccortyp,nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) - allocate(vlor1sccor(maxterm_sccor,nsccortyp,nsccortyp)) - allocate(vlor2sccor(maxterm_sccor,nsccortyp,nsccortyp)) - allocate(vlor3sccor(maxterm_sccor,nsccortyp,nsccortyp)) !(maxterm_sccor,20,20) -!----------------------------------- - allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) -!----------------------------------- - allocate(nterm_sccor(-nsccortyp:nsccortyp,-nsccortyp:nsccortyp)) !(-ntyp:ntyp,-ntyp:ntyp) - allocate(v1sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& - -nsccortyp:nsccortyp)) - allocate(v2sccor(maxterm_sccor,maxinter,-nsccortyp:nsccortyp,& - -nsccortyp:nsccortyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) - allocate(v0sccor(maxinter,-nsccortyp:nsccortyp,& - -nsccortyp:nsccortyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) -!----------------------------------- - do i=-nsccortyp,nsccortyp - do j=-nsccortyp,nsccortyp - nterm_sccor(j,i)=0 - enddo - enddo -!----------------------------------- - - read (isccor,*) (isccortyp(i),i=1,ntyp) - do i=-ntyp,-1 - isccortyp(i)=-isccortyp(-i) - enddo - iscprol=isccortyp(20) -! write (iout,*) 'ntortyp',ntortyp -! maxinter=3 -!c maxinter is maximum interaction sites - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*) & - nterm_sccor(i,j),nlor_sccor(i,j) - v0ijsccor=0.0d0 - v0ijsccor1=0.0d0 - v0ijsccor2=0.0d0 - v0ijsccor3=0.0d0 - si=-1.0d0 - nterm_sccor(-i,j)=nterm_sccor(i,j) - nterm_sccor(-i,-j)=nterm_sccor(i,j) - nterm_sccor(i,-j)=nterm_sccor(i,j) - do k=1,nterm_sccor(i,j) - read (isccor,*) kk,v1sccor(k,l,i,j),& - v2sccor(k,l,i,j) - if (j.eq.iscprol) then - if (i.eq.isccortyp(10)) then - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - else - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0 & - +v2sccor(k,l,i,j)*dsqrt(0.75d0) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0 & - +v1sccor(k,l,i,j)*dsqrt(0.75d0) - v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) - endif - else - if (i.eq.isccortyp(10)) then - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - else - if (j.eq.isccortyp(10)) then - v1sccor(k,l,-i,j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j) - else - v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) - endif - endif - endif - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j) - v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j) - v0ijsccor3=v0ijsccor+si*v1sccor(k,l,-i,-j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*) kk,vlor1sccor(k,i,j),& - vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ & - (1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(l,i,j)=v0ijsccor - v0sccor(l,-i,j)=v0ijsccor1 - v0sccor(l,i,-j)=v0ijsccor2 - v0sccor(l,-i,-j)=v0ijsccor3 - enddo - enddo - enddo - close (isccor) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants of SCCORR:' - do i=1,nsccortyp - do j=1,nsccortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm_sccor(i,j) - write (iout,'(2(1pe15.5))') & - (v1sccor(k,l,i,j),v2sccor(k,l,i,j),l=1,maxinter) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor_sccor(i,j) - write (iout,'(3(1pe15.5))') & - vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) - enddo - enddo - enddo - endif -! -! 9/18/99 (AL) Read coefficients of the Fourier expansion of the local -! interaction energy of the Gly, Ala, and Pro prototypes. -! - read (ifourier,*) nloctyp -!el write(iout,*)"nloctyp",nloctyp -!el from module energy------- - allocate(b1(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) - allocate(b2(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) - allocate(b1tilde(2,-nloctyp-1:nloctyp+1)) !(2,-maxtor:maxtor) - allocate(cc(2,2,-nloctyp-1:nloctyp+1)) - allocate(dd(2,2,-nloctyp-1:nloctyp+1)) - allocate(ee(2,2,-nloctyp-1:nloctyp+1)) - allocate(ctilde(2,2,-nloctyp-1:nloctyp+1)) - allocate(dtilde(2,2,-nloctyp-1:nloctyp+1)) !(2,2,-maxtor:maxtor) - do i=1,2 - do ii=-nloctyp-1,nloctyp+1 - b1(i,ii)=0.0d0 - b2(i,ii)=0.0d0 - b1tilde(i,ii)=0.0d0 - do j=1,2 - cc(j,i,ii)=0.0d0 - dd(j,i,ii)=0.0d0 - ee(j,i,ii)=0.0d0 - ctilde(j,i,ii)=0.0d0 - dtilde(j,i,ii)=0.0d0 - enddo - enddo - enddo -!-------------------------------- - allocate(b(13,0:nloctyp)) - - do i=0,nloctyp-1 - read (ifourier,*) - read (ifourier,*) (b(ii,i),ii=1,13) - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) - endif - B1(1,i) = b(3,i) - B1(2,i) = b(5,i) - B1(1,-i) = b(3,i) - B1(2,-i) = -b(5,i) -! b1(1,i)=0.0d0 -! b1(2,i)=0.0d0 - B1tilde(1,i) = b(3,i) - B1tilde(2,i) =-b(5,i) - B1tilde(1,-i) =-b(3,i) - B1tilde(2,-i) =b(5,i) -! b1tilde(1,i)=0.0d0 -! b1tilde(2,i)=0.0d0 - B2(1,i) = b(2,i) - B2(2,i) = b(4,i) - B2(1,-i) =b(2,i) - B2(2,-i) =-b(4,i) - -! b2(1,i)=0.0d0 -! b2(2,i)=0.0d0 - CC(1,1,i)= b(7,i) - CC(2,2,i)=-b(7,i) - CC(2,1,i)= b(9,i) - CC(1,2,i)= b(9,i) - CC(1,1,-i)= b(7,i) - CC(2,2,-i)=-b(7,i) - CC(2,1,-i)=-b(9,i) - CC(1,2,-i)=-b(9,i) -! CC(1,1,i)=0.0d0 -! CC(2,2,i)=0.0d0 -! CC(2,1,i)=0.0d0 -! CC(1,2,i)=0.0d0 - Ctilde(1,1,i)=b(7,i) - Ctilde(1,2,i)=b(9,i) - Ctilde(2,1,i)=-b(9,i) - Ctilde(2,2,i)=b(7,i) - Ctilde(1,1,-i)=b(7,i) - Ctilde(1,2,-i)=-b(9,i) - Ctilde(2,1,-i)=b(9,i) - Ctilde(2,2,-i)=b(7,i) - -! Ctilde(1,1,i)=0.0d0 -! Ctilde(1,2,i)=0.0d0 -! Ctilde(2,1,i)=0.0d0 -! Ctilde(2,2,i)=0.0d0 - DD(1,1,i)= b(6,i) - DD(2,2,i)=-b(6,i) - DD(2,1,i)= b(8,i) - DD(1,2,i)= b(8,i) - DD(1,1,-i)= b(6,i) - DD(2,2,-i)=-b(6,i) - DD(2,1,-i)=-b(8,i) - DD(1,2,-i)=-b(8,i) -! DD(1,1,i)=0.0d0 -! DD(2,2,i)=0.0d0 -! DD(2,1,i)=0.0d0 -! DD(1,2,i)=0.0d0 - Dtilde(1,1,i)=b(6,i) - Dtilde(1,2,i)=b(8,i) - Dtilde(2,1,i)=-b(8,i) - Dtilde(2,2,i)=b(6,i) - Dtilde(1,1,-i)=b(6,i) - Dtilde(1,2,-i)=-b(8,i) - Dtilde(2,1,-i)=b(8,i) - Dtilde(2,2,-i)=b(6,i) - -! Dtilde(1,1,i)=0.0d0 -! Dtilde(1,2,i)=0.0d0 -! Dtilde(2,1,i)=0.0d0 -! Dtilde(2,2,i)=0.0d0 - EE(1,1,i)= b(10,i)+b(11,i) - EE(2,2,i)=-b(10,i)+b(11,i) - EE(2,1,i)= b(12,i)-b(13,i) - EE(1,2,i)= b(12,i)+b(13,i) - EE(1,1,-i)= b(10,i)+b(11,i) - EE(2,2,-i)=-b(10,i)+b(11,i) - EE(2,1,-i)=-b(12,i)+b(13,i) - EE(1,2,-i)=-b(12,i)-b(13,i) - -! ee(1,1,i)=1.0d0 -! ee(2,2,i)=1.0d0 -! ee(2,1,i)=0.0d0 -! ee(1,2,i)=0.0d0 -! ee(2,1,i)=ee(1,2,i) - - enddo - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' -! write (iout,'(f10.5)') B1(:,i) - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' -! write (iout,'(f10.5)') B2(:,i) - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) - enddo - enddo - endif -! -! Read electrostatic-interaction parameters -! - if (lprint) then - write (iout,'(/a)') 'Electrostatic interaction constants:' - write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') & - 'IT','JT','APP','BPP','AEL6','AEL3' - endif - read (ielep,*) ((epp(i,j),j=1,2),i=1,2) - read (ielep,*) ((rpp(i,j),j=1,2),i=1,2) - read (ielep,*) ((elpp6(i,j),j=1,2),i=1,2) - read (ielep,*) ((elpp3(i,j),j=1,2),i=1,2) - close (ielep) - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - app (i,j)=epp(i,j)*rri*rri - bpp (i,j)=-2.0D0*epp(i,j)*rri - ael6(i,j)=elpp6(i,j)*4.2D0**6 - ael3(i,j)=elpp3(i,j)*4.2D0**3 - if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j),& - ael6(i,j),ael3(i,j) - enddo - enddo -! -! Read side-chain interaction parameters. -! -!el from module energy - COMMON.INTERACT------- - allocate(eps(ntyp,ntyp),sigmaii(ntyp,ntyp),rs0(ntyp,ntyp)) !(ntyp,ntyp) - allocate(augm(ntyp,ntyp)) !(ntyp,ntyp) - allocate(eps_scp(ntyp,2),rscp(ntyp,2)) !(ntyp,2) - allocate(sigma0(ntyp),rr0(ntyp),sigii(ntyp)) !(ntyp) - allocate(chip(ntyp1),alp(ntyp1)) !(ntyp) - do i=1,ntyp - do j=1,ntyp - augm(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 - enddo -!-------------------------------- - - read (isidep,*) ipot,expon -!el if (ipot.lt.1 .or. ipot.gt.5) then -! write (iout,'(2a)') 'Error while reading SC interaction',& -! 'potential file - unknown potential type.' -! stop -!wl endif - expon2=expon/2 - write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot),& - ', exponents are ',expon,2*expon -! goto (10,20,30,30,40) ipot - select case(ipot) -!----------------------- LJ potential --------------------------------- - case (1) -! 10 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),(sigma0(i),i=1,ntyp) - read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),(sigma0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJ potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,a)') 'residue','sigma' - write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) - endif -! goto 50 -!----------------------- LJK potential -------------------------------- - case (2) -! 20 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& - read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& - (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i),& - i=1,ntyp) - endif -! goto 50 -!---------------------- GB or BP potential ----------------------------- - case (3:4) -! 30 do i=1,ntyp - do i=1,ntyp - read (isidep,*)(eps(i,j),j=i,ntyp) - enddo - read (isidep,*)(sigma0(i),i=1,ntyp) - read (isidep,*)(sigii(i),i=1,ntyp) - read (isidep,*)(chip(i),i=1,ntyp) - read (isidep,*)(alp(i),i=1,ntyp) -! For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) - enddo - endif - if (lprint) then - write (iout,'(/a/)') 'Parameters of the BP potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2',& - ' chip ',' alph ' - write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i),& - chip(i),alp(i),i=1,ntyp) - endif -! goto 50 -!--------------------- GBV potential ----------------------------------- - case (5) -! 40 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& - read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),& - (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp),& - (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ',& - 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i),& - sigii(i),chip(i),alp(i),i=1,ntyp) - endif - case default - write (iout,'(2a)') 'Error while reading SC interaction',& - 'potential file - unknown potential type.' - stop -! 50 continue - end select -! continue - close (isidep) -!----------------------------------------------------------------------- -! Calculate the "working" parameters of SC interactions. - -!el from module energy - COMMON.INTERACT------- - allocate(aa(ntyp1,ntyp1),bb(ntyp1,ntyp1),chi(ntyp1,ntyp1)) !(ntyp,ntyp) - allocate(sigma(0:ntyp1,0:ntyp1),r0(ntyp1,ntyp1)) !(0:ntyp1,0:ntyp1) - do i=1,ntyp1 - do j=1,ntyp1 - aa(i,j)=0.0D0 - bb(i,j)=0.0D0 - chi(i,j)=0.0D0 - sigma(i,j)=0.0D0 - r0(i,j)=0.0D0 - enddo - enddo -!-------------------------------- - - do i=2,ntyp - do j=1,i-1 - eps(i,j)=eps(j,i) - enddo - enddo - do i=1,ntyp - do j=i,ntyp - sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) - sigma(j,i)=sigma(i,j) - rs0(i,j)=dwa16*sigma(i,j) - rs0(j,i)=rs0(i,j) - enddo - enddo - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') & - 'Working parameters of the SC interactions:',& - ' a ',' b ',' augm ',' sigma ',' r0 ',& - ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - if (ipot.gt.2) then - sigt1sq=sigma0(i)**2 - sigt2sq=sigma0(j)**2 - sigii1=sigii(i) - sigii2=sigii(j) - ratsig1=sigt2sq/sigt1sq - ratsig2=1.0D0/ratsig1 - chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) - if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) - rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) - else - rsum_max=sigma(i,j) - endif -! if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - sigmaii(i,j)=rsum_max - sigmaii(j,i)=rsum_max -! else -! sigmaii(i,j)=r0(i,j) -! sigmaii(j,i)=r0(i,j) -! endif -!d write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max - if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then - r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij - augm(i,j)=epsij*r_augm**(2*expon) -! augm(i,j)=0.5D0**(2*expon)*aa(i,j) - augm(j,i)=augm(i,j) - else - augm(i,j)=0.0D0 - augm(j,i)=0.0D0 - endif - if (lprint) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') & - restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j),& - sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - endif - enddo - enddo - - allocate(aad(ntyp,2),bad(ntyp,2)) !(ntyp,2) - do i=1,ntyp - do j=1,2 - bad(i,j)=0.0D0 - enddo - enddo -#ifdef CLUSTER -! -! Define the SC-p interaction constants -! - do i=1,20 - do j=1,2 - eps_scp(i,j)=-1.5d0 - rscp(i,j)=4.0d0 - enddo - enddo -#endif - -!elwrite(iout,*) "parmread kontrol before oldscp" -! -! Define the SC-p interaction constants -! -#ifdef OLDSCP - do i=1,20 -! "Soft" SC-p repulsion (causes helices to be too flat, but facilitates -! helix formation) -! aad(i,1)=0.3D0*4.0D0**12 -! Following line for constants currently implemented -! "Hard" SC-p repulsion (gives correct turn spacing in helices) - aad(i,1)=1.5D0*4.0D0**12 -! aad(i,1)=0.17D0*5.6D0**12 - aad(i,2)=aad(i,1) -! "Soft" SC-p repulsion - bad(i,1)=0.0D0 -! Following line for constants currently implemented -! aad(i,1)=0.3D0*4.0D0**6 -! "Hard" SC-p repulsion - bad(i,1)=3.0D0*4.0D0**6 -! bad(i,1)=-2.0D0*0.17D0*5.6D0**6 - bad(i,2)=bad(i,1) -! aad(i,1)=0.0D0 -! aad(i,2)=0.0D0 -! bad(i,1)=1228.8D0 -! bad(i,2)=1228.8D0 - enddo -#else -! -! 8/9/01 Read the SC-p interaction constants from file -! - do i=1,ntyp - read (iscpp,*) (eps_scp(i,j),rscp(i,j),j=1,2) - enddo - do i=1,ntyp - aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 - aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 - bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 - bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 - enddo - - if (lprint) then - write (iout,*) "Parameters of SC-p interactions:" - do i=1,20 - write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1),& - eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) - enddo - endif -#endif -! -! Define the constants of the disulfide bridge -! - ebr=-5.50D0 -! -! Old arbitrary potential - commented out. -! -! dbr= 4.20D0 -! fbr= 3.30D0 -! -! Constants of the disulfide-bond potential determined based on the RHF/6-31G** -! energy surface of diethyl disulfide. -! A. Liwo and U. Kozlowska, 11/24/03 -! - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 - - if (lprint) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,& - ' v3ss:',v3ss - endif - return - end subroutine parmread -#ifndef CLUSTER -!----------------------------------------------------------------------------- -! mygetenv.F -!----------------------------------------------------------------------------- - subroutine mygetenv(string,var) -! -! Version 1.0 -! -! This subroutine passes the environmental variables to FORTRAN program. -! If the flags -DMYGETENV and -DMPI are not for compilation, it calls the -! standard FORTRAN GETENV subroutine. If both flags are set, the subroutine -! reads the environmental variables from $HOME/.env -! -! Usage: As for the standard FORTRAN GETENV subroutine. -! -! Purpose: some versions/installations of MPI do not transfer the environmental -! variables to slave processors, if these variables are set in the shell script -! from which mpirun is called. -! -! A.Liwo, 7/29/01 -! -#ifdef MPI - use MPI_data - include "mpif.h" -#endif -! implicit none - character*(*) :: string,var -#if defined(MYGETENV) && defined(MPI) -! include "DIMENSIONS.ZSCOPT" -! include "mpif.h" -! include "COMMON.MPI" -!el character*360 ucase -!el external ucase - character(len=360) :: string1(360),karta - character(len=240) :: home - integer i,n !,ilen -!el external ilen - call getenv("HOME",home) - open(99,file=home(:ilen(home))//"/.env",status="OLD",err=112) - do while (.true.) - read (99,end=111,err=111,'(a)') karta - do i=1,80 - string1(i)=" " - enddo - call split_string(karta,string1,80,n) - if (ucase(string1(1)(:ilen(string1(1)))).eq."SETENV" .and. & - string1(2)(:ilen(string1(2))).eq.string(:ilen(string)) ) then - var=string1(3) - print *,"Processor",me,": ",var(:ilen(var)),& - " assigned to ",string(:ilen(string)) - close(99) - return - endif - enddo - 111 print *,"Environment variable ",string(:ilen(string))," not set." - close(99) - return - 112 print *,"Error opening environment file!" -#else - call getenv(string,var) -#endif - return - end subroutine mygetenv -!----------------------------------------------------------------------------- -! readrtns.F -!----------------------------------------------------------------------------- - subroutine read_general_data(*) - - use control_data, only:indpdb,symetr - use energy_data, only:distchainmax -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! include "COMMON.TORSION" -! include "COMMON.INTERACT" -! include "COMMON.IOUNITS" -! include "COMMON.TIME1" -! include "COMMON.PROT" -! include "COMMON.PROTFILES" -! include "COMMON.CHAIN" -! include "COMMON.NAMES" -! include "COMMON.FFIELD" -! include "COMMON.ENEPS" -! include "COMMON.WEIGHTS" -! include "COMMON.FREE" -! include "COMMON.CONTROL" -! include "COMMON.ENERGIES" - character(len=800) :: controlcard - integer :: i,j,k,ii,n_ene_found - integer :: ind,itype1,itype2,itypf,itypsc,itypp -!el integer ilen -!el external ilen -!el character*16 ucase - character(len=16) :: key -!el external ucase - call card_concat(controlcard,.true.) - call readi(controlcard,"N_ENE",n_eneW,max_eneW) - if (n_eneW.gt.max_eneW) then - write (iout,*) "Error: parameter out of range: N_ENE",n_eneW,& - max_eneW - return 1 - endif - call readi(controlcard,"NPARMSET",nparmset,1) -!elwrite(iout,*)"in read_gen data" - separate_parset = index(controlcard,"SEPARATE_PARSET").gt.0 - call readi(controlcard,"IPARMPRINT",iparmprint,1) - write (iout,*) "PARMPRINT",iparmprint - if (nparmset.gt.max_parm) then - write (iout,*) "Error: parameter out of range: NPARMSET",& - nparmset, Max_Parm - return 1 - endif -!elwrite(iout,*)"in read_gen data" - call readi(controlcard,"MAXIT",maxit,5000) - call reada(controlcard,"FIMIN",fimin,1.0d-3) - call readi(controlcard,"ENSEMBLES",ensembles,0) - hamil_rep=index(controlcard,"HAMIL_REP").gt.0 - write (iout,*) "Number of energy parameter sets",nparmset - allocate(isampl(nparmset)) - call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) - write (iout,*) "MaxSlice",MaxSlice - call readi(controlcard,"NSLICE",nslice,1) -!elwrite(iout,*)"in read_gen data" - call flush(iout) - if (nslice.gt.MaxSlice) then - write (iout,*) "Error: parameter out of range: NSLICE",nslice,& - MaxSlice - return 1 - endif - write (iout,*) "Frequency of storing conformations",& - (isampl(i),i=1,nparmset) - write (iout,*) "Maxit",maxit," Fimin",fimin - call readi(controlcard,"NQ",nQ,1) - if (nQ.gt.MaxQ) then - write (iout,*) "Error: parameter out of range: NQ",nq,& - maxq - return 1 - endif - indpdb=0 - if (index(controlcard,"CLASSIFY").gt.0) indpdb=1 - call reada(controlcard,"DELTA",delta,1.0d-2) - call readi(controlcard,"EINICHECK",einicheck,2) - call reada(controlcard,"DELTRMS",deltrms,5.0d-2) - call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) - call readi(controlcard,"RESCALE",rescale_modeW,1) - check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 - call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) - call readi(controlcard,'SYM',symetr,1) - write (iout,*) "DISTCHAINMAX",distchainmax - write (iout,*) "delta",delta - write (iout,*) "einicheck",einicheck - write (iout,*) "rescale_mode",rescale_modeW - call flush(iout) - bxfile=index(controlcard,"BXFILE").gt.0 - cxfile=index(controlcard,"CXFILE").gt.0 - if (nslice .eq. 1 .and. .not.bxfile .and. .not.cxfile) & - bxfile=.true. - histfile=index(controlcard,"HISTFILE").gt.0 - histout=index(controlcard,"HISTOUT").gt.0 - entfile=index(controlcard,"ENTFILE").gt.0 - zscfile=index(controlcard,"ZSCFILE").gt.0 - with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 - write (iout,*) "with_dihed_constr ",with_dihed_constr - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - return - end subroutine read_general_data -!------------------------------------------------------------------------------ - subroutine read_efree(*) -! -! Read molecular data -! -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.CHAIN' -! include 'COMMON.HEADER' -! include 'COMMON.GEO' -! include 'COMMON.FREE' - character(len=320) :: controlcard !,ucase - integer :: iparm,ib,i,j,npars -!el integer ilen -!el external ilen - - if (hamil_rep) then - npars=1 - else - npars=nParmSet - endif - -! call alloc_wham_arrays -! allocate(nT_h(nParmSet)) -! allocate(replica(nParmSet)) -! allocate(umbrella(nParmSet)) -! allocate(read_iset(nParmSet)) -! allocate(nT_h(nParmSet)) - - do iparm=1,npars - - call card_concat(controlcard,.true.) - call readi(controlcard,'NT',nT_h(iparm),1) - write (iout,*) "iparm",iparm," nt",nT_h(iparm) - call flush(iout) - if (nT_h(iparm).gt.MaxT_h) then - write (iout,*) "Error: parameter out of range: NT",nT_h(iparm),& - MaxT_h - return 1 - endif - replica(iparm)=index(controlcard,"REPLICA").gt.0 - umbrella(iparm)=index(controlcard,"UMBRELLA").gt.0 - read_iset(iparm)=index(controlcard,"READ_ISET").gt.0 - write (iout,*) "nQ",nQ," nT",nT_h(iparm)," replica ",& - replica(iparm)," umbrella ",umbrella(iparm),& - " read_iset",read_iset(iparm) - call flush(iout) - do ib=1,nT_h(iparm) - call card_concat(controlcard,.true.) - call readi(controlcard,'NR',nR(ib,iparm),1) - if (umbrella(iparm)) then - nRR(ib,iparm)=1 - else - nRR(ib,iparm)=nR(ib,iparm) - endif - if (nR(ib,iparm).gt.MaxR) then - write (iout,*) "Error: parameter out of range: NR",& - nR(ib,iparm),MaxR - return 1 - endif - call reada(controlcard,'TEMP',beta_h(ib,iparm),298.0d0) - beta_h(ib,iparm)=1.0d0/(beta_h(ib,iparm)*1.987D-3) - call multreada(controlcard,'FI',f(1,ib,iparm),nR(ib,iparm),& - 0.0d0) - do i=1,nR(ib,iparm) - call card_concat(controlcard,.true.) - call multreada(controlcard,'KH',KH(1,i,ib,iparm),nQ,& - 100.0d0) - call multreada(controlcard,'Q0',Q0(1,i,ib,iparm),nQ,& - 0.0d0) - enddo - enddo - do ib=1,nT_h(iparm) - write (iout,*) "ib",ib," beta_h",& - 1.0d0/(0.001987*beta_h(ib,iparm)) - write (iout,*) "nR",nR(ib,iparm) - write (iout,*) "fi",(f(i,ib,iparm),i=1,nR(ib,iparm)) - do i=1,nR(ib,iparm) - write (iout,*) "i",i," Kh",(Kh(j,i,ib,iparm),j=1,nQ),& - "q0",(q0(j,i,ib,iparm),j=1,nQ) - enddo - call flush(iout) - enddo - - enddo - - if (hamil_rep) then - - do iparm=2,nParmSet - nT_h(iparm)=nT_h(1) - do ib=1,nT_h(iparm) - nR(ib,iparm)=nR(ib,1) - if (umbrella(iparm)) then - nRR(ib,iparm)=1 - else - nRR(ib,iparm)=nR(ib,1) - endif - beta_h(ib,iparm)=beta_h(ib,1) - do i=1,nR(ib,iparm) - f(i,ib,iparm)=f(i,ib,1) - do j=1,nQ - KH(j,i,ib,iparm)=KH(j,i,ib,1) - Q0(j,i,ib,iparm)=Q0(j,i,ib,1) - enddo - enddo - replica(iparm)=replica(1) - umbrella(iparm)=umbrella(1) - read_iset(iparm)=read_iset(1) - enddo - enddo - - endif - - return - end subroutine read_efree -!----------------------------------------------------------------------------- - subroutine read_protein_data(*) -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -#ifdef MPI - use MPI_data - include "mpif.h" - integer :: IERROR,ERRCODE!,STATUS(MPI_STATUS_SIZE) -! include "COMMON.MPI" -#endif -! include "COMMON.CHAIN" -! include "COMMON.IOUNITS" -! include "COMMON.PROT" -! include "COMMON.PROTFILES" -! include "COMMON.NAMES" -! include "COMMON.FREE" -! include "COMMON.OBCINKA" - character(len=64) :: nazwa - character(len=16000) :: controlcard - integer :: i,ii,ib,iR,iparm,nthr,npars !,ilen,iroof -!el external ilen,iroof - if (hamil_rep) then - npars=1 - else - npars=nparmset - endif - - do iparm=1,npars - -! Read names of files with conformation data. - if (replica(iparm)) then - nthr = 1 - else - nthr = nT_h(iparm) - endif - do ib=1,nthr - do ii=1,nRR(ib,iparm) - write (iout,*) "Parameter set",iparm," temperature",ib,& - " window",ii - call flush(iout) - call card_concat(controlcard,.true.) - write (iout,*) controlcard(:ilen(controlcard)) - call readi(controlcard,"NFILE_BIN",nfile_bin(ii,ib,iparm),0) - call readi(controlcard,"NFILE_ASC",nfile_asc(ii,ib,iparm),0) - call readi(controlcard,"NFILE_CX",nfile_cx(ii,ib,iparm),0) - call readi(controlcard,"REC_START",rec_start(ii,ib,iparm),1) - call readi(controlcard,"REC_END",rec_end(ii,ib,iparm),& - maxstr*isampl(iparm)+rec_start(ii,ib,iparm)-1) - call reada(controlcard,"TIME_START",& - time_start_collect(ii,ib,iparm),0.0d0) - call reada(controlcard,"TIME_END",time_end_collect(ii,ib,iparm),& - 1.0d10) - write (iout,*) "rec_start",rec_start(ii,ib,iparm),& - " rec_end",rec_end(ii,ib,iparm) - write (iout,*) "time_start",time_start_collect(ii,ib,iparm),& - " time_end",time_end_collect(ii,ib,iparm) - call flush(iout) - if (replica(iparm)) then - call readi(controlcard,"TOTRAJ",totraj(ii,iparm),1) - write (iout,*) "Number of trajectories",totraj(ii,iparm) - call flush(iout) - endif - if (nfile_bin(ii,ib,iparm).lt.2 & - .and. nfile_asc(ii,ib,iparm).eq.0 & - .and. nfile_cx(ii,ib,iparm).eq.0) then - write (iout,*) "Error - no action specified!" - return 1 - endif - if (nfile_bin(ii,ib,iparm).gt.0) then - call card_concat(controlcard,.false.) - call split_string(controlcard,protfiles(1,1,ii,ib,iparm),& - maxfile_prot,nfile_bin(ii,ib,iparm)) -#ifdef DEBUG - write(iout,*)"nfile_bin",nfile_bin(ii,ib,iparm) - write(iout,*) (protfiles(i,1,ii,ib,iparm),& - i=1,nfile_bin(ii,ib,iparm)) -#endif - endif - if (nfile_asc(ii,ib,iparm).gt.0) then - call card_concat(controlcard,.false.) - call split_string(controlcard,protfiles(1,2,ii,ib,iparm),& - maxfile_prot,nfile_asc(ii,ib,iparm)) -#ifdef DEBUG - write(iout,*) "nfile_asc(ii,ib,iparm)",nfile_asc(ii,ib,iparm) - write(iout,*) (protfiles(i,2,ii,ib,iparm),& - i=1,nfile_asc(ii,ib,iparm)) -#endif - else if (nfile_cx(ii,ib,iparm).gt.0) then - call card_concat(controlcard,.false.) - call split_string(controlcard,protfiles(1,2,ii,ib,iparm),& - maxfile_prot,nfile_cx(ii,ib,iparm)) -#ifdef DEBUG - write(iout,*) "nfile_cx(ii,ib,iparm)",nfile_cx(ii,ib,iparm) - write(iout,*) (protfiles(i,2,ii,ib,iparm),& - i=1,nfile_cx(ii,ib,iparm)) -#endif - endif - call flush(iout) - enddo - enddo - - enddo - return - end subroutine read_protein_data -!------------------------------------------------------------------------------- - subroutine readsss(rekord,lancuch,wartosc,default) -! implicit none - character*(*) :: rekord,lancuch,wartosc,default - character(len=80) :: aux - integer :: lenlan,lenrec,iread,ireade -!el external ilen -!el logical iblnk -!el external iblnk - lenlan=ilen(lancuch) - lenrec=ilen(rekord) - iread=index(rekord,lancuch(:lenlan)//"=") -! print *,"rekord",rekord," lancuch",lancuch -! print *,"iread",iread," lenlan",lenlan," lenrec",lenrec - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+lenlan+1 -! print *,"iread",iread -! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) - do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) - iread=iread+1 -! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) - enddo -! print *,"iread",iread - if (iread.gt.lenrec) then - wartosc=default - return - endif - ireade=iread+1 -! print *,"ireade",ireade - do while (ireade.lt.lenrec .and. & - .not.iblnk(rekord(ireade:ireade))) - ireade=ireade+1 - enddo - wartosc=rekord(iread:ireade) - return - end subroutine readsss -!---------------------------------------------------------------------------- - subroutine multreads(rekord,lancuch,tablica,dim,default) -! implicit none - integer :: dim,i - character*(*) rekord,lancuch,tablica(dim),default - character(len=80) :: aux - integer :: lenlan,lenrec,iread,ireade -!el external ilen -!el logical iblnk -!el external iblnk - do i=1,dim - tablica(i)=default - enddo - lenlan=ilen(lancuch) - lenrec=ilen(rekord) - iread=index(rekord,lancuch(:lenlan)//"=") -! print *,"rekord",rekord," lancuch",lancuch -! print *,"iread",iread," lenlan",lenlan," lenrec",lenrec - if (iread.eq.0) return - iread=iread+lenlan+1 - do i=1,dim -! print *,"iread",iread -! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) - do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) - iread=iread+1 -! print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) - enddo -! print *,"iread",iread - if (iread.gt.lenrec) return - ireade=iread+1 -! print *,"ireade",ireade - do while (ireade.lt.lenrec .and. & - .not.iblnk(rekord(ireade:ireade))) - ireade=ireade+1 - enddo - tablica(i)=rekord(iread:ireade) - iread=ireade+1 - enddo - end subroutine multreads -!---------------------------------------------------------------------------- - subroutine split_string(rekord,tablica,dim,nsub) -! implicit none - integer :: dim,nsub,i,ii,ll,kk - character*(*) tablica(dim) - character*(*) rekord -!el integer ilen -!el external ilen - do i=1,dim - tablica(i)=" " - enddo - ii=1 - ll = ilen(rekord) - nsub=0 - do i=1,dim -! Find the start of term name - kk = 0 - do while (ii.le.ll .and. rekord(ii:ii).eq." ") - ii = ii+1 - enddo -! Parse the name into TABLICA(i) until blank found - do while (ii.le.ll .and. rekord(ii:ii).ne." ") - kk = kk+1 - tablica(i)(kk:kk)=rekord(ii:ii) - ii = ii+1 - enddo - if (kk.gt.0) nsub=nsub+1 - if (ii.gt.ll) return - enddo - return - end subroutine split_string -!-------------------------------------------------------------------------------- -! readrtns_compar.F -!-------------------------------------------------------------------------------- - subroutine read_compar -! -! Read molecular data -! - use conform_compar, only:alloc_compar_arrays - use control_data, only:pdbref - use geometry_data, only:deg2rad,rad2deg -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! include 'DIMENSIONS.FREE' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CONTROL' -! include 'COMMON.COMPAR' -! include 'COMMON.CHAIN' -! include 'COMMON.HEADER' -! include 'COMMON.GEO' -! include 'COMMON.FREE' - character(len=320) :: controlcard !,ucase - character(len=64) :: wfile -!el integer ilen -!el external ilen - integer :: i,j,k -!elwrite(iout,*)"jestesmy w read_compar" - call card_concat(controlcard,.true.) - pdbref=(index(controlcard,'PDBREF').gt.0) - call reada(controlcard,'CUTOFF_UP',rmscut_base_up,4.0d0) - call reada(controlcard,'CUTOFF_LOW',rmscut_base_low,3.0d0) - call reada(controlcard,'RMSUP_LIM',rmsup_lim,4.0d0) - call reada(controlcard,'RMSUPUP_LIM',rmsupup_lim,7.5d0) - verbose = index(controlcard,"VERBOSE").gt.0 - lgrp=index(controlcard,"STATIN").gt.0 - lgrp_out=index(controlcard,"STATOUT").gt.0 - merge_helices=index(controlcard,"DONT_MERGE_HELICES").eq.0 - binary = index(controlcard,"BINARY").gt.0 - rmscut_base_up=rmscut_base_up/50 - rmscut_base_low=rmscut_base_low/50 - call reada(controlcard,"FRAC_SEC",frac_sec,0.66666666d0) - call readi(controlcard,'NLEVEL',nlevel,1) - if (nlevel.lt.0) then - allocate(nfrag(2)) - call alloc_compar_arrays(maxfrag,1) - goto 121 - else - allocate(nfrag(nlevel)) - endif -! Read the data pertaining to elementary fragments (level 1) - call readi(controlcard,'NFRAG',nfrag(1),0) - write(iout,*)"nfrag(1)",nfrag(1) - call alloc_compar_arrays(nfrag(1),nlevel) - do j=1,nfrag(1) - call card_concat(controlcard,.true.) - write (iout,*) controlcard(:ilen(controlcard)) - call readi(controlcard,'NPIECE',npiece(j,1),0) - call readi(controlcard,'N_SHIFT1',n_shift(1,j,1),0) - call readi(controlcard,'N_SHIFT2',n_shift(2,j,1),0) - call reada(controlcard,'ANGCUT',ang_cut(j),50.0d0) - call reada(controlcard,'MAXANG',ang_cut1(j),360.0d0) - call reada(controlcard,'FRAC_MIN',frac_min(j),0.666666d0) - call reada(controlcard,'NC_FRAC',nc_fragm(j,1),0.5d0) - call readi(controlcard,'NC_REQ',nc_req_setf(j,1),0) - call readi(controlcard,'RMS',irms(j,1),0) - call readi(controlcard,'LOCAL',iloc(j),1) - call readi(controlcard,'ELCONT',ielecont(j,1),1) - if (ielecont(j,1).eq.0) then - call readi(controlcard,'SCCONT',isccont(j,1),1) - endif - ang_cut(j)=ang_cut(j)*deg2rad - ang_cut1(j)=ang_cut1(j)*deg2rad - do k=1,npiece(j,1) - call card_concat(controlcard,.true.) - call readi(controlcard,'IFRAG1',ifrag(1,k,j),0) - call readi(controlcard,'IFRAG2',ifrag(2,k,j),0) - enddo - write(iout,*)"j",j," npiece",npiece(j,1)," ifrag",& - (ifrag(1,k,j),ifrag(2,k,j),& - k=1,npiece(j,1))," ang_cut",ang_cut(j)*rad2deg,& - " ang_cut1",ang_cut1(j)*rad2deg - write(iout,*)"n_shift",n_shift(1,j,1),n_shift(2,j,1) - write(iout,*)"nc_frac",nc_fragm(j,1)," nc_req",nc_req_setf(j,1) - write(iout,*)"irms",irms(j,1)," ielecont",ielecont(j,1),& - " ilocal",iloc(j)," isccont",isccont(j,1) - enddo -! Read data pertaning to higher levels - do i=2,nlevel - call card_concat(controlcard,.true.) - call readi(controlcard,'NFRAG',NFRAG(i),0) - write (iout,*) "i",i," nfrag",nfrag(i) - do j=1,nfrag(i) - call card_concat(controlcard,.true.) - if (i.eq.2) then - call readi(controlcard,'ELCONT',ielecont(j,i),0) - if (ielecont(j,i).eq.0) then - call readi(controlcard,'SCCONT',isccont(j,i),1) - endif - call readi(controlcard,'RMS',irms(j,i),0) - else - ielecont(j,i)=0 - isccont(j,i)=0 - irms(j,i)=1 - endif - call readi(controlcard,'NPIECE',npiece(j,i),0) - call readi(controlcard,'N_SHIFT1',n_shift(1,j,i),0) - call readi(controlcard,'N_SHIFT2',n_shift(2,j,i),0) - call multreadi(controlcard,'IPIECE',ipiece(1,j,i),& - npiece(j,i),0) - call reada(controlcard,'NC_FRAC',nc_fragm(j,i),0.5d0) - call readi(controlcard,'NC_REQ',nc_req_setf(j,i),0) - write(iout,*) "j",j," npiece",npiece(j,i)," n_shift",& - n_shift(1,j,i),n_shift(2,j,i)," ielecont",ielecont(j,i),& - " isccont",isccont(j,i)," irms",irms(j,i) - write(iout,*) "ipiece",(ipiece(k,j,i),k=1,npiece(j,i)) - write(iout,*)"n_shift",n_shift(1,j,i),n_shift(2,j,i) - write(iout,*)"nc_frac",nc_fragm(j,i),& - " nc_req",nc_req_setf(j,i) - enddo - enddo - if (binary) write (iout,*) "Classes written in binary format." - return - 121 continue - call reada(controlcard,'ANGCUT_HEL',angcut_hel,50.0d0) - call reada(controlcard,'MAXANG_HEL',angcut1_hel,60.0d0) - call reada(controlcard,'ANGCUT_BET',angcut_bet,90.0d0) - call reada(controlcard,'MAXANG_BET',angcut1_bet,360.0d0) - call reada(controlcard,'ANGCUT_STRAND',angcut_strand,90.0d0) - call reada(controlcard,'MAXANG_STRAND',angcut1_strand,60.0d0) - call reada(controlcard,'FRAC_MIN',frac_min_set,0.666666d0) - call reada(controlcard,'NC_FRAC_HEL',ncfrac_hel,0.5d0) - call readi(controlcard,'NC_REQ_HEL',ncreq_hel,0) - call reada(controlcard,'NC_FRAC_BET',ncfrac_bet,0.5d0) - call reada(controlcard,'NC_FRAC_PAIR',ncfrac_pair,0.3d0) - call readi(controlcard,'NC_REQ_BET',ncreq_bet,0) - call readi(controlcard,'NC_REQ_PAIR',ncreq_pair,0) - call readi(controlcard,'NSHIFT_HEL',nshift_hel,3) - call readi(controlcard,'NSHIFT_BET',nshift_bet,3) - call readi(controlcard,'NSHIFT_STRAND',nshift_strand,3) - call readi(controlcard,'NSHIFT_PAIR',nshift_pair,3) - call readi(controlcard,'RMS_SINGLE',irms_single,0) - call readi(controlcard,'CONT_SINGLE',icont_single,1) - call readi(controlcard,'LOCAL_SINGLE',iloc_single,1) - call readi(controlcard,'RMS_PAIR',irms_pair,0) - call readi(controlcard,'CONT_PAIR',icont_pair,1) - call readi(controlcard,'SPLIT_BET',isplit_bet,0) - angcut_hel=angcut_hel*deg2rad - angcut1_hel=angcut1_hel*deg2rad - angcut_bet=angcut_bet*deg2rad - angcut1_bet=angcut1_bet*deg2rad - angcut_strand=angcut_strand*deg2rad - angcut1_strand=angcut1_strand*deg2rad - write (iout,*) "Automatic detection of structural elements" - write (iout,*) 'NC_FRAC_HEL',ncfrac_hel,' NC_REQ_HEL',ncreq_hel,& - ' NC_FRAC_BET',ncfrac_bet,' NC_REQ_BET',ncreq_bet,& - ' RMS_SINGLE',irms_single,' CONT_SINGLE',icont_single,& - ' NC_FRAC_PAIR',ncfrac_pair,' NC_REQ_PAIR',ncreq_pair,& - ' RMS_PAIR',irms_pair,' CONT_PAIR',icont_pair,& - ' SPLIT_BET',isplit_bet - write (iout,*) 'NSHIFT_HEL',nshift_hel,' NSHIFT_BET',nshift_bet,& - ' NSHIFT_STRAND',nshift_strand,' NSHIFT_PAIR',nshift_pair - write (iout,*) 'ANGCUT_HEL',angcut_hel*rad2deg,& - ' MAXANG_HEL',angcut1_hel*rad2deg - write (iout,*) 'ANGCUT_BET',angcut_bet*rad2deg,& - ' MAXANG_BET',angcut1_bet*rad2deg - write (iout,*) 'ANGCUT_STRAND',angcut_strand*rad2deg,& - ' MAXANG_STRAND',angcut1_strand*rad2deg - write (iout,*) 'FRAC_MIN',frac_min_set - return - end subroutine read_compar -!-------------------------------------------------------------------------------- -! read_ref_str.F -!-------------------------------------------------------------------------------- - subroutine read_ref_structure(*) -! -! Read the reference structure from the PDB file or from a PDB file or in the form of the dihedral -! angles. -! - use control_data, only:pdbref - use geometry_data, only:nres,cref,c,dc,nsup,dc_norm,nend_sup,& - nstart_sup,nstart_seq,nperm,nres0 - use energy_data, only:nct,nnt,icont_ref,ncont_ref,itype - use compare, only:seq_comp !,contact,elecont - use geometry, only:chainbuild,dist - use io_config, only:readpdb -! - use conform_compar, only:contact,elecont -! implicit none -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'DIMENSIONS.COMPAR' -! 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.CONTACTS1' -! include 'COMMON.PEPTCONT' -! include 'COMMON.TIME1' -! include 'COMMON.COMPAR' - character(len=4) :: sequence(nres) -!el integer rescode -!el real(kind=8) :: x(maxvar) - integer :: itype_pdb(nres) -!el logical seq_comp - integer :: i,j,k,nres_pdb,iaux - real(kind=8) :: ddsc !el,dist - integer :: kkk !,ilen -!el external ilen -! - nres0=nres - write (iout,*) "pdbref",pdbref - if (pdbref) then - read(inp,'(a)') pdbfile - write (iout,'(2a,1h.)') 'PDB data will be read from file ',& - pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - return 1 - 34 continue - do i=1,nres - itype_pdb(i)=itype(i) - enddo - - call readpdb - - do i=1,nres - iaux=itype_pdb(i) - itype_pdb(i)=itype(i) - itype(i)=iaux - enddo - close (ipdbin) - do kkk=1,nperm - nres_pdb=nres - nres=nres0 - nstart_seq=nnt - if (nsup.le.(nct-nnt+1)) then - do i=0,nct-nnt+1-nsup - if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),& - nsup)) then - do j=nnt+nsup-1,nnt,-1 - do k=1,3 - cref(k,nres+j+i,kkk)=cref(k,nres_pdb+j,kkk) - enddo - enddo - do j=nnt+nsup-1,nnt,-1 - do k=1,3 - cref(k,j+i,kkk)=cref(k,j,kkk) - enddo - phi_ref(j+i)=phi_ref(j) - theta_ref(j+i)=theta_ref(j) - alph_ref(j+i)=alph_ref(j) - omeg_ref(j+i)=omeg_ref(j) - enddo -#ifdef DEBUG - do j=nnt,nct - write (iout,'(i5,3f10.5,5x,3f10.5)') & - j,(cref(k,j,kkk),k=1,3),(cref(k,j+nres,kkk),k=1,3) - enddo -#endif - nstart_seq=nnt+i - nstart_sup=nnt+i - goto 111 - endif - enddo - write (iout,'(a)') & - 'Error - sequences to be superposed do not match.' - return 1 - else - do i=0,nsup-(nct-nnt+1) - if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),& - nct-nnt+1)) & - then - nstart_sup=nstart_sup+i - nsup=nct-nnt+1 - goto 111 - endif - enddo - write (iout,'(a)') & - 'Error - sequences to be superposed do not match.' - endif - enddo - 111 continue - write (iout,'(a,i5)') & - 'Experimental structure begins at residue',nstart_seq - else - call read_angles(inp,*38) - goto 39 - 38 write (iout,'(a)') 'Error reading reference structure.' - return 1 - 39 call chainbuild - kkk=1 - nstart_sup=nnt - nstart_seq=nnt - nsup=nct-nnt+1 - do i=1,2*nres - do j=1,3 - cref(j,i,kkk)=c(j,i) - enddo - enddo - endif - nend_sup=nstart_sup+nsup-1 - do i=1,2*nres - do j=1,3 - c(j,i)=cref(j,i,kkk) - enddo - enddo - do i=1,nres - do j=1,3 - dc(j,nres+i)=cref(j,nres+i,kkk)-cref(j,i,kkk) - enddo - if (itype(i).ne.10) then - ddsc = dist(i,nres+i) - do j=1,3 - dc_norm(j,nres+i)=dc(j,nres+i)/ddsc - enddo - else - do j=1,3 - dc_norm(j,nres+i)=0.0d0 - enddo - endif -! write (iout,*) "i",i," dc_norm",(dc_norm(k,nres+i),k=1,3), -! " norm",dc_norm(1,nres+i)**2+dc_norm(2,nres+i)**2+ -! dc_norm(3,nres+i)**2 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - enddo - ddsc = dist(i,i+1) - do j=1,3 - dc_norm(j,i)=dc(j,i)/ddsc - enddo - enddo -! print *,"Calling contact" - call contact(.true.,ncont_ref,icont_ref(1,1),& - nstart_sup,nend_sup) -! print *,"Calling elecont" - call elecont(.true.,ncont_pept_ref,& - icont_pept_ref(1,1),& - nstart_sup,nend_sup) - write (iout,'(a,i3,a,i3,a,i3,a)') & - 'Number of residues to be superposed:',nsup,& - ' (from residue',nstart_sup,' to residue',& - nend_sup,').' - return - end subroutine read_ref_structure -!-------------------------------------------------------------------------------- -! geomout.F -!-------------------------------------------------------------------------------- - subroutine pdboutW(ii,temp,efree,etot,entropy,rmsdev) - - use geometry_data, only:nres,c - use energy_data, only:nss,nnt,nct,ihpb,jhpb,itype -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'DIMENSIONS.ZSCOPT' -! include 'COMMON.CHAIN' -! include 'COMMON.INTERACT' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' -! include 'COMMON.HEADER' -! include 'COMMON.SBRIDGE' - character(len=50) :: tytul - character(len=1),dimension(10) :: chainid=reshape((/'A','B','C',& - 'D','E','F','G','H','I','J'/),shape(chainid)) - integer,dimension(nres) :: ica !(maxres) - real(kind=8) :: temp,efree,etot,entropy,rmsdev - integer :: ii,i,j,iti,ires,iatom,ichain - write(ipdb,'("REMARK CONF",i8," TEMPERATURE",f7.1," RMS",0pf7.2)')& - ii,temp,rmsdev - write (ipdb,'("REMARK DIMENSIONLESS FREE ENERGY",1pe15.5)') & - efree - write (ipdb,'("REMARK ENERGY",1pe15.5," ENTROPY",1pe15.5)') & - etot,entropy - iatom=0 - ichain=1 - ires=0 - do i=nnt,nct - iti=itype(i) - if (iti.eq.ntyp1) then - ichain=ichain+1 - ires=0 - write (ipdb,'(a)') 'TER' - else - ires=ires+1 - iatom=iatom+1 - ica(i)=iatom - write (ipdb,10) iatom,restyp(iti),chainid(ichain),& - ires,(c(j,i),j=1,3) - if (iti.ne.10) then - iatom=iatom+1 - write (ipdb,20) iatom,restyp(iti),chainid(ichain),& - ires,(c(j,nres+i),j=1,3) - endif - endif - enddo - write (ipdb,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.ntyp1) cycle - if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then - write (ipdb,30) ica(i),ica(i+1) - else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then - write (ipdb,30) ica(i),ica(i+1),ica(i)+1 - else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then - write (ipdb,30) ica(i),ica(i)+1 - endif - enddo - if (itype(nct).ne.10) then - write (ipdb,30) ica(nct),ica(nct)+1 - endif - do i=1,nss - write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 - enddo - write (ipdb,'(a6)') 'ENDMDL' - 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,f15.3) - 30 FORMAT ('CONECT',8I5) - return - end subroutine pdboutW -#endif -!------------------------------------------------------------------------------ - end module io_wham -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - diff --git a/source/wham/w_comm_local.F90 b/source/wham/w_comm_local.F90 new file mode 100644 index 0000000..0df9100 --- /dev/null +++ b/source/wham/w_comm_local.F90 @@ -0,0 +1,9 @@ + module w_comm_local +!------------------------------------------------------------------------------- +! common /ccc/ + real(kind=8),dimension(:,:),allocatable :: creff,cc !(3,nres*2) + logical,dimension(:),allocatable :: iadded !(nres) + integer,dimension(:,:),allocatable :: inumber !(2,nres) +!------------------------------------------------------------------------------- + end module w_comm_local + diff --git a/source/wham/w_comm_local.f90 b/source/wham/w_comm_local.f90 deleted file mode 100644 index 0df9100..0000000 --- a/source/wham/w_comm_local.f90 +++ /dev/null @@ -1,9 +0,0 @@ - module w_comm_local -!------------------------------------------------------------------------------- -! common /ccc/ - real(kind=8),dimension(:,:),allocatable :: creff,cc !(3,nres*2) - logical,dimension(:),allocatable :: iadded !(nres) - integer,dimension(:,:),allocatable :: inumber !(2,nres) -!------------------------------------------------------------------------------- - end module w_comm_local - diff --git a/source/wham/w_compar_data.F90 b/source/wham/w_compar_data.F90 new file mode 100644 index 0000000..00b2d2a --- /dev/null +++ b/source/wham/w_compar_data.F90 @@ -0,0 +1,55 @@ + module w_compar_data +!--------------------------------------------------------------------------- +! use names +!--------------------------------------------------------------------------- +! commom.contacts (in energy_data) +! common /contacts/ + integer,dimension(:),allocatable :: nsccont_frag_ref !(mmaxfrag) !wham + integer,dimension(:,:,:),allocatable :: isccont_frag_ref !(2,maxcont,mmaxfrag) !wham +!----------------------------------------------------------------------------- +! COMMON.COMPAR +! common /compar/ + real(kind=8),dimension(:,:),allocatable :: rmsfrag,& + nc_fragm !(maxfrag,maxlevel) + real(kind=8),dimension(:,:),allocatable :: qfrag !(maxfrag,2) + real(kind=8) :: rmscut_base_low,rmscut_base_up,& + rmsup_lim,rmsupup_lim + real(kind=8),dimension(:,:,:),allocatable :: rmscutfrag !(2,maxfrag,maxlevel) + real(kind=8) :: rms_nat,qnat,rmsang + real(kind=8),dimension(:),allocatable :: ang_cut,ang_cut1,frac_min!(maxfrag) + integer,dimension(:,:),allocatable :: nc_req_setf,npiece,& + ielecont,isccont,irms,ishifft,len_frag !(maxfrag,maxlevel) + integer,dimension(:,:,:),allocatable :: ncont_nat,& + n_shift !(2,maxfrag,maxlevel) + integer,dimension(:),allocatable :: nfrag !(maxlevel) + integer,dimension(:),allocatable :: isnfrag !(maxlevel+1) + integer,dimension(:,:,:),allocatable :: ifrag !(2,maxpiece,maxfrag) + integer,dimension(:,:,:),allocatable :: ipiece !(maxpiece,maxfrag,2:maxlevel) + integer,dimension(:),allocatable ::istruct,iloc,nlist_frag !(maxfrag) + integer,dimension(:,:),allocatable :: iclass !(maxlevel*maxfrag,maxlevel) + integer :: iscore,nlevel,ibase + logical :: lgrp,lgrp_out,binary + integer,dimension(:,:),allocatable :: list_frag !(maxres,maxfrag) +! common /compar1/ + real(kind=8) :: angcut_hel,angcut1_hel,angcut_bet,angcut1_bet,& + angcut_strand,angcut1_strand,frac_min_set,ncfrac_hel,& + ncfrac_bet,ncfrac_pair,frac_sec + integer :: ncreq_hel,ncreq_bet,ncreq_pair,irms_pair,& + icont_pair,isplit_bet,nshift_hel,nshift_bet,nshift_strand,& + nshift_pair,irms_single,icont_single,iloc_single +!--------------------------------------------------------------------------- +! COMMON.VAR +! Angles from experimental structure +! common /varref/ + real(kind=8),dimension(:),allocatable :: vbld_ref,theta_ref,& + phi_ref,alph_ref,omeg_ref !(maxres) +!--------------------------------------------------------------------------- +! COMMON.CONTPAR +! common /contpar/ + real(kind=8),dimension(:,:),allocatable :: sig_comp,chi_comp,& + chip_comp,sc_cutoff !(ntyp,ntyp) +! real(kind=8),dimension(ntyp,ntyp) :: sig_comp,chi_comp,& +! chip_comp,sc_cutoff !(ntyp,ntyp) +!--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- + end module w_compar_data diff --git a/source/wham/w_compar_data.f90 b/source/wham/w_compar_data.f90 deleted file mode 100644 index 00b2d2a..0000000 --- a/source/wham/w_compar_data.f90 +++ /dev/null @@ -1,55 +0,0 @@ - module w_compar_data -!--------------------------------------------------------------------------- -! use names -!--------------------------------------------------------------------------- -! commom.contacts (in energy_data) -! common /contacts/ - integer,dimension(:),allocatable :: nsccont_frag_ref !(mmaxfrag) !wham - integer,dimension(:,:,:),allocatable :: isccont_frag_ref !(2,maxcont,mmaxfrag) !wham -!----------------------------------------------------------------------------- -! COMMON.COMPAR -! common /compar/ - real(kind=8),dimension(:,:),allocatable :: rmsfrag,& - nc_fragm !(maxfrag,maxlevel) - real(kind=8),dimension(:,:),allocatable :: qfrag !(maxfrag,2) - real(kind=8) :: rmscut_base_low,rmscut_base_up,& - rmsup_lim,rmsupup_lim - real(kind=8),dimension(:,:,:),allocatable :: rmscutfrag !(2,maxfrag,maxlevel) - real(kind=8) :: rms_nat,qnat,rmsang - real(kind=8),dimension(:),allocatable :: ang_cut,ang_cut1,frac_min!(maxfrag) - integer,dimension(:,:),allocatable :: nc_req_setf,npiece,& - ielecont,isccont,irms,ishifft,len_frag !(maxfrag,maxlevel) - integer,dimension(:,:,:),allocatable :: ncont_nat,& - n_shift !(2,maxfrag,maxlevel) - integer,dimension(:),allocatable :: nfrag !(maxlevel) - integer,dimension(:),allocatable :: isnfrag !(maxlevel+1) - integer,dimension(:,:,:),allocatable :: ifrag !(2,maxpiece,maxfrag) - integer,dimension(:,:,:),allocatable :: ipiece !(maxpiece,maxfrag,2:maxlevel) - integer,dimension(:),allocatable ::istruct,iloc,nlist_frag !(maxfrag) - integer,dimension(:,:),allocatable :: iclass !(maxlevel*maxfrag,maxlevel) - integer :: iscore,nlevel,ibase - logical :: lgrp,lgrp_out,binary - integer,dimension(:,:),allocatable :: list_frag !(maxres,maxfrag) -! common /compar1/ - real(kind=8) :: angcut_hel,angcut1_hel,angcut_bet,angcut1_bet,& - angcut_strand,angcut1_strand,frac_min_set,ncfrac_hel,& - ncfrac_bet,ncfrac_pair,frac_sec - integer :: ncreq_hel,ncreq_bet,ncreq_pair,irms_pair,& - icont_pair,isplit_bet,nshift_hel,nshift_bet,nshift_strand,& - nshift_pair,irms_single,icont_single,iloc_single -!--------------------------------------------------------------------------- -! COMMON.VAR -! Angles from experimental structure -! common /varref/ - real(kind=8),dimension(:),allocatable :: vbld_ref,theta_ref,& - phi_ref,alph_ref,omeg_ref !(maxres) -!--------------------------------------------------------------------------- -! COMMON.CONTPAR -! common /contpar/ - real(kind=8),dimension(:,:),allocatable :: sig_comp,chi_comp,& - chip_comp,sc_cutoff !(ntyp,ntyp) -! real(kind=8),dimension(ntyp,ntyp) :: sig_comp,chi_comp,& -! chip_comp,sc_cutoff !(ntyp,ntyp) -!--------------------------------------------------------------------------- -!--------------------------------------------------------------------------- - end module w_compar_data diff --git a/source/wham/wham.F90 b/source/wham/wham.F90 new file mode 100644 index 0000000..fcf1d15 --- /dev/null +++ b/source/wham/wham.F90 @@ -0,0 +1,372 @@ + program wham_multparm +! program WHAM_multparm +! Creation/update of the database of conformations + use wham_data + use io_wham + use io_database + use wham_calc + use ene_calc + use conform_compar + use work_part +! + use io_units + use control_data, only:indpdb +#ifdef MPI + use mpi_data +! use mpi_ +#endif + use control, only:initialize +!el use io_config, only:parmread +! +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$ATTRIBUTES C :: proc_proc +#endif +#endif +! +!el#ifndef ISNAN +!el external proc_proc +!el#endif +!el#ifdef WINPGI +!elcMS$ATTRIBUTES C :: proc_proc +!el#endif +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! implicit none +#ifdef MPI +! include "COMMON.MPI" +! use mpi_data + include "mpif.h" + integer :: IERROR,ERRCODE +#endif +! include "COMMON.IOUNITS" +! include "COMMON.FREE" +! include "COMMON.CONTROL" +! include "COMMON.ALLPARM" +! include "COMMON.PROT" + real(kind=8) :: rr !,x(max_paropt) + integer :: idumm + integer :: i,ipar,islice + +!el run_wham=.true. +!#define WHAM_RUN +! call alloc_wham_arrays +!write(iout,*) "after alloc wham" +#ifdef MPI + call MPI_Init( IERROR ) + call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR ) + call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR ) + Master = 0 + if (ierror.gt.0) then + write(iout,*) "SEVERE ERROR - Can't initialize MPI." + call mpi_finalize(ierror) + stop + endif +!el if (nprocs.gt.MaxProcs+1) then +!el write (2,*) "Error - too many processors",& +!el nprocs,MaxProcs+1 +!el write (2,*) "Increase MaxProcs and recompile" +!el call MPI_Finalize(IERROR) +!el stop +!el endif +#endif +! NaNQ initialization +#ifndef ISNAN + i=-1 + rr=dacos(100.0d0) +#ifdef WINPGI + idumm=proc_proc(rr,i) +#else + call proc_proc(rr,i) +#endif +#endif +!write(iout,*) "before init" + call initialize +!write(iout,*)"after init" + call openunits +!write(iout,*)"after open ui" + call cinfo +!write(iout,*)"after cinfo" + call read_general_data(*10) +!write(iout,*)"after read_gen" + call flush(iout) + call molread(*10) +!write(iout,*)"after molread" + call flush(iout) +#ifdef MPI + write (iout,*) "Calling proc_groups" + call proc_groups + write (iout,*) "proc_groups exited" + call flush(iout) +#endif +!el---------- + call alloc_wham_arrays +!el---------- + do ipar=1,nParmSet + write (iout,*) "Calling parmread",ipar + call parmread(ipar,*10) + if (.not.separate_parset) then + call store_parm(ipar) + write (iout,*) "Finished storing parameters",ipar + else if (ipar.eq.myparm) then + call store_parm(1) + write (iout,*) "Finished storing parameters",ipar + endif + call flush(iout) + enddo + call read_efree(*10) + write (iout,*) "Finished READ_EFREE" + call flush(iout) + call read_protein_data(*10) + write (iout,*) "Finished READ_PROTEIN_DATA" + call flush(iout) + if (indpdb.gt.0) then + call promienie + call read_compar + call read_ref_structure(*10) +!write(iout,*)"before proc_cont, define frag" + call proc_cont + call fragment_list + if (constr_dist.gt.0) call read_dist_constr + endif + write (iout,*) "Begin read_database" + call flush(iout) + call read_database(*10) + write (iout,*) "Finished read_database" + call flush(iout) + if (separate_parset) nparmset=1 + do islice=1,nslice + if (ntot(islice).gt.0) then +#ifdef MPI + call work_partition(islice,.true.) + write (iout,*) "work_partition OK" + call flush(iout) +#endif + write (iout,*) "call enecalc",islice,nslice + call enecalc(islice,*10) + write (iout,*) "enecalc OK" + call flush(iout) + call WHAMCALC(islice,*10) + write (iout,*) "wham_calc OK" + call flush(iout) + call write_dbase(islice,*10) + write (iout,*) "write_dbase OK" + call flush(iout) + if (ensembles.gt.0) then + call make_ensembles(islice,*10) + write (iout,*) "make_ensembles OK" + call flush(iout) + endif + endif + enddo +#ifdef MPI + call MPI_Finalize( IERROR ) +#endif + stop + 10 write (iout,*) "Error termination of the program" +#ifdef MPI + call MPI_Finalize( IERROR ) +#endif + stop + end program wham_multparm +!------------------------------------------------------------------------------ +! +!------------------------------------------------------------------------------ +#ifdef MPI + subroutine proc_groups +! Split the processors into the Master and Workers group, if needed. + use io_units + use MPI_data + use wham_data + + implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" +! include "COMMON.IOUNITS" +! include "COMMON.MPI" +! include "COMMON.FREE" + include "mpif.h" + integer :: n,chunk,i,j,ii,remainder + integer :: kolorW,key,ierror,errcode + logical :: lprint + lprint=.true. +! +! Split the communicator if independent runs for different parameter +! sets will be performed. +! + if (nparmset.eq.1 .or. .not.separate_parset) then + WHAM_COMM = MPI_COMM_WORLD + else if (separate_parset) then + if (nprocs.lt.nparmset) then + write (iout,*) & + "*** Cannot split parameter sets for fewer processors than sets",& + nprocs,nparmset + call MPI_Finalize(ierror) + stop + endif + write (iout,*) "nparmset",nparmset + nprocs = nprocs/nparmset + kolorW = me/nprocs + key = mod(me,nprocs) + write (iout,*) "My old rank",me," kolor",kolorW," key",key + call MPI_Comm_split(MPI_COMM_WORLD,kolorW,key,WHAM_COMM,ierror) + call MPI_Comm_size(WHAM_COMM,nprocs,ierror) + call MPI_Comm_rank(WHAM_COMM,me,ierror) + write (iout,*) "My new rank",me," comm size",nprocs + write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,& + " WHAM_COMM",WHAM_COMM + myparm=kolorW+1 + write (iout,*) "My parameter set is",myparm + call flush(iout) + else + myparm=nparmset + endif + Me1 = Me + Nprocs1 = Nprocs + return + end subroutine proc_groups +#endif +!------------------------------------------------------------------------------ +#ifdef AIX + subroutine flush(iu) + call flush_(iu) + return + end subroutine flush +#endif +!----------------------------------------------------------------------------- + subroutine promienie(*) + + use io_units + use names + use io_base, only:ucase + use energy_data, only:sigma0,dsc,dsc_inv + use wham_data + use w_compar_data + implicit none +! include 'DIMENSIONS' +! include 'COMMON.CONTROL' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' +! include 'COMMON.CONTPAR' +! include 'COMMON.LOCAL' + integer ::i,j + real(kind=8) :: facont=1.569D0 ! facont = (2/(1-sqrt(1-1/4)))**(1/6) + character(len=8) :: contfunc + character(len=8) :: contfuncid(5)=reshape((/'GB ',& + 'DIST ','CEN ','ODC ','SIG '/),shape(contfuncid)) +!el character(len=8) ucase + call getenv("CONTFUNC",contfunc) + contfunc=ucase(contfunc) + do icomparfunc=1,5 + if (contfunc.eq.contfuncid(icomparfunc)) goto 10 + enddo + 10 continue + write (iout,*) "Sidechain contact function is ",contfunc,& + "icomparfunc",icomparfunc + do i=1,ntyp + do j=1,ntyp + if (icomparfunc.lt.3) then + read(isidep1,*) chi_comp(i,j),chip_comp(i,j),sig_comp(i,j),& + sc_cutoff(i,j) + else if (icomparfunc.lt.5) then + read(isidep1,*) sc_cutoff(i,j) + else if (icomparfunc.eq.5) then + sc_cutoff(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2)*facont + else + write (iout,*) "Error - Unknown contact function" + return 1 + endif + enddo + enddo + close (isidep1) + do i=1,ntyp1 + if (i.eq.10 .or. i.eq.ntyp1) then + dsc_inv(i)=0.0d0 + else + dsc_inv(i)=1.0d0/dsc(i) + endif + enddo + return + end subroutine promienie +!----------------------------------------------------------------------------- + subroutine alloc_wham_arrays + + use names + use geometry_data, only:nres + use energy_data, only:maxcont + use wham_data + use w_compar_data + integer :: i,j,k,l +!------------------------- +! COMMON.FREE +! common /wham/ + allocate(stot(nslice)) !(maxslice) + do i=1,nslice + stot(i)=0 + enddo + allocate(Kh(nQ,MaxR,MaxT_h,nParmSet),q0(nQ,MaxR,MaxT_h,nParmSet))!(MaxQ,MaxR,MaxT_h,max_parm) + allocate(f(maxR,maxT_h,nParmSet)) !(maxR,maxT_h,max_parm) + allocate(beta_h(maxT_h,nParmSet)) !(MaxT_h,max_parm) + allocate(nR(maxT_h,nParmSet),nRR(maxT_h,nParmSet)) !(maxT_h,max_parm) + allocate(snk(MaxR,MaxT_h,nParmSet,nSlice)) !(MaxR,MaxT_h,max_parm,MaxSlice) +! do i=1,MaxR +! do j=1,MaxT_h +! do k=1,nParmSet +! do l=1,nSlice +! snk(i,j,k,l)=0 +! enddo +! enddo +! enddo +! enddo + + allocate(totraj(maxR,nParmSet)) !(maxR,max_parm) + + allocate(nT_h(nParmSet))!(max_parm) + allocate(replica(nParmSet)) + allocate(umbrella(nParmSet)) + allocate(read_iset(nParmSet)) +! allocate(nT_h(nParmSet)) +!------------------------- +! COMMON.PROT +! common /protein/ + allocate(ntot(nslice)) !(maxslice) +! allocatable :: isampl !(max_parm) +!------------------------- +! COMMON.PROTFILES +! common /protfil/ + allocate(protfiles(maxfile_prot,2,MaxR,MaxT_h,nParmSet)) !(maxfile_prot,2,MaxR,MaxT_h,Max_Parm) + allocate(nfile_bin(MaxR,MaxT_h,nParmSet)) + allocate(nfile_asc(MaxR,MaxT_h,nParmSet)) + allocate(nfile_cx(MaxR,MaxT_h,nParmSet)) + allocate(rec_start(MaxR,MaxT_h,nParmSet)) + allocate(rec_end(MaxR,MaxT_h,nParmSet)) !(MaxR,MaxT_h,Max_Parm) +!------------------------- +! COMMON.OBCINKA +! common /obcinka/ + allocate(time_start_collect(maxR,MaxT_h,nParmSet)) + allocate(time_end_collect(maxR,MaxT_h,nParmSet)) !(maxR,MaxT_h,Max_Parm) +!------------------------- +! COMMON.CONTPAR +! common /contpar/ + allocate(sig_comp(ntyp,ntyp),chi_comp(ntyp,ntyp),& + chip_comp(ntyp,ntyp),sc_cutoff(ntyp,ntyp)) !(ntyp,ntyp) +!------------------------- +! COMMON.PEPTCONT +! common /peptcont/ + allocate(icont_pept_ref(2,maxcont)) !(2,maxcont) +! allocate(ncont_frag_ref()) !(mmaxfrag) +! allocate(icont_frag_ref(2,maxcont)) !(2,maxcont,mmaxfrag) + allocate(isec_ref(nres)) !(maxres) +!------------------------- +! COMMON.VAR +! Angles from experimental structure +! common /varref/ + allocate(vbld_ref(nres),theta_ref(nres),& + phi_ref(nres),alph_ref(nres),omeg_ref(nres)) !(maxres) +!------------------------- + end subroutine alloc_wham_arrays +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- diff --git a/source/wham/wham.f90 b/source/wham/wham.f90 deleted file mode 100644 index fcf1d15..0000000 --- a/source/wham/wham.f90 +++ /dev/null @@ -1,372 +0,0 @@ - program wham_multparm -! program WHAM_multparm -! Creation/update of the database of conformations - use wham_data - use io_wham - use io_database - use wham_calc - use ene_calc - use conform_compar - use work_part -! - use io_units - use control_data, only:indpdb -#ifdef MPI - use mpi_data -! use mpi_ -#endif - use control, only:initialize -!el use io_config, only:parmread -! -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$ATTRIBUTES C :: proc_proc -#endif -#endif -! -!el#ifndef ISNAN -!el external proc_proc -!el#endif -!el#ifdef WINPGI -!elcMS$ATTRIBUTES C :: proc_proc -!el#endif -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! implicit none -#ifdef MPI -! include "COMMON.MPI" -! use mpi_data - include "mpif.h" - integer :: IERROR,ERRCODE -#endif -! include "COMMON.IOUNITS" -! include "COMMON.FREE" -! include "COMMON.CONTROL" -! include "COMMON.ALLPARM" -! include "COMMON.PROT" - real(kind=8) :: rr !,x(max_paropt) - integer :: idumm - integer :: i,ipar,islice - -!el run_wham=.true. -!#define WHAM_RUN -! call alloc_wham_arrays -!write(iout,*) "after alloc wham" -#ifdef MPI - call MPI_Init( IERROR ) - call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR ) - call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR ) - Master = 0 - if (ierror.gt.0) then - write(iout,*) "SEVERE ERROR - Can't initialize MPI." - call mpi_finalize(ierror) - stop - endif -!el if (nprocs.gt.MaxProcs+1) then -!el write (2,*) "Error - too many processors",& -!el nprocs,MaxProcs+1 -!el write (2,*) "Increase MaxProcs and recompile" -!el call MPI_Finalize(IERROR) -!el stop -!el endif -#endif -! NaNQ initialization -#ifndef ISNAN - i=-1 - rr=dacos(100.0d0) -#ifdef WINPGI - idumm=proc_proc(rr,i) -#else - call proc_proc(rr,i) -#endif -#endif -!write(iout,*) "before init" - call initialize -!write(iout,*)"after init" - call openunits -!write(iout,*)"after open ui" - call cinfo -!write(iout,*)"after cinfo" - call read_general_data(*10) -!write(iout,*)"after read_gen" - call flush(iout) - call molread(*10) -!write(iout,*)"after molread" - call flush(iout) -#ifdef MPI - write (iout,*) "Calling proc_groups" - call proc_groups - write (iout,*) "proc_groups exited" - call flush(iout) -#endif -!el---------- - call alloc_wham_arrays -!el---------- - do ipar=1,nParmSet - write (iout,*) "Calling parmread",ipar - call parmread(ipar,*10) - if (.not.separate_parset) then - call store_parm(ipar) - write (iout,*) "Finished storing parameters",ipar - else if (ipar.eq.myparm) then - call store_parm(1) - write (iout,*) "Finished storing parameters",ipar - endif - call flush(iout) - enddo - call read_efree(*10) - write (iout,*) "Finished READ_EFREE" - call flush(iout) - call read_protein_data(*10) - write (iout,*) "Finished READ_PROTEIN_DATA" - call flush(iout) - if (indpdb.gt.0) then - call promienie - call read_compar - call read_ref_structure(*10) -!write(iout,*)"before proc_cont, define frag" - call proc_cont - call fragment_list - if (constr_dist.gt.0) call read_dist_constr - endif - write (iout,*) "Begin read_database" - call flush(iout) - call read_database(*10) - write (iout,*) "Finished read_database" - call flush(iout) - if (separate_parset) nparmset=1 - do islice=1,nslice - if (ntot(islice).gt.0) then -#ifdef MPI - call work_partition(islice,.true.) - write (iout,*) "work_partition OK" - call flush(iout) -#endif - write (iout,*) "call enecalc",islice,nslice - call enecalc(islice,*10) - write (iout,*) "enecalc OK" - call flush(iout) - call WHAMCALC(islice,*10) - write (iout,*) "wham_calc OK" - call flush(iout) - call write_dbase(islice,*10) - write (iout,*) "write_dbase OK" - call flush(iout) - if (ensembles.gt.0) then - call make_ensembles(islice,*10) - write (iout,*) "make_ensembles OK" - call flush(iout) - endif - endif - enddo -#ifdef MPI - call MPI_Finalize( IERROR ) -#endif - stop - 10 write (iout,*) "Error termination of the program" -#ifdef MPI - call MPI_Finalize( IERROR ) -#endif - stop - end program wham_multparm -!------------------------------------------------------------------------------ -! -!------------------------------------------------------------------------------ -#ifdef MPI - subroutine proc_groups -! Split the processors into the Master and Workers group, if needed. - use io_units - use MPI_data - use wham_data - - implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" -! include "COMMON.IOUNITS" -! include "COMMON.MPI" -! include "COMMON.FREE" - include "mpif.h" - integer :: n,chunk,i,j,ii,remainder - integer :: kolorW,key,ierror,errcode - logical :: lprint - lprint=.true. -! -! Split the communicator if independent runs for different parameter -! sets will be performed. -! - if (nparmset.eq.1 .or. .not.separate_parset) then - WHAM_COMM = MPI_COMM_WORLD - else if (separate_parset) then - if (nprocs.lt.nparmset) then - write (iout,*) & - "*** Cannot split parameter sets for fewer processors than sets",& - nprocs,nparmset - call MPI_Finalize(ierror) - stop - endif - write (iout,*) "nparmset",nparmset - nprocs = nprocs/nparmset - kolorW = me/nprocs - key = mod(me,nprocs) - write (iout,*) "My old rank",me," kolor",kolorW," key",key - call MPI_Comm_split(MPI_COMM_WORLD,kolorW,key,WHAM_COMM,ierror) - call MPI_Comm_size(WHAM_COMM,nprocs,ierror) - call MPI_Comm_rank(WHAM_COMM,me,ierror) - write (iout,*) "My new rank",me," comm size",nprocs - write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,& - " WHAM_COMM",WHAM_COMM - myparm=kolorW+1 - write (iout,*) "My parameter set is",myparm - call flush(iout) - else - myparm=nparmset - endif - Me1 = Me - Nprocs1 = Nprocs - return - end subroutine proc_groups -#endif -!------------------------------------------------------------------------------ -#ifdef AIX - subroutine flush(iu) - call flush_(iu) - return - end subroutine flush -#endif -!----------------------------------------------------------------------------- - subroutine promienie(*) - - use io_units - use names - use io_base, only:ucase - use energy_data, only:sigma0,dsc,dsc_inv - use wham_data - use w_compar_data - implicit none -! include 'DIMENSIONS' -! include 'COMMON.CONTROL' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CONTPAR' -! include 'COMMON.LOCAL' - integer ::i,j - real(kind=8) :: facont=1.569D0 ! facont = (2/(1-sqrt(1-1/4)))**(1/6) - character(len=8) :: contfunc - character(len=8) :: contfuncid(5)=reshape((/'GB ',& - 'DIST ','CEN ','ODC ','SIG '/),shape(contfuncid)) -!el character(len=8) ucase - call getenv("CONTFUNC",contfunc) - contfunc=ucase(contfunc) - do icomparfunc=1,5 - if (contfunc.eq.contfuncid(icomparfunc)) goto 10 - enddo - 10 continue - write (iout,*) "Sidechain contact function is ",contfunc,& - "icomparfunc",icomparfunc - do i=1,ntyp - do j=1,ntyp - if (icomparfunc.lt.3) then - read(isidep1,*) chi_comp(i,j),chip_comp(i,j),sig_comp(i,j),& - sc_cutoff(i,j) - else if (icomparfunc.lt.5) then - read(isidep1,*) sc_cutoff(i,j) - else if (icomparfunc.eq.5) then - sc_cutoff(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2)*facont - else - write (iout,*) "Error - Unknown contact function" - return 1 - endif - enddo - enddo - close (isidep1) - do i=1,ntyp1 - if (i.eq.10 .or. i.eq.ntyp1) then - dsc_inv(i)=0.0d0 - else - dsc_inv(i)=1.0d0/dsc(i) - endif - enddo - return - end subroutine promienie -!----------------------------------------------------------------------------- - subroutine alloc_wham_arrays - - use names - use geometry_data, only:nres - use energy_data, only:maxcont - use wham_data - use w_compar_data - integer :: i,j,k,l -!------------------------- -! COMMON.FREE -! common /wham/ - allocate(stot(nslice)) !(maxslice) - do i=1,nslice - stot(i)=0 - enddo - allocate(Kh(nQ,MaxR,MaxT_h,nParmSet),q0(nQ,MaxR,MaxT_h,nParmSet))!(MaxQ,MaxR,MaxT_h,max_parm) - allocate(f(maxR,maxT_h,nParmSet)) !(maxR,maxT_h,max_parm) - allocate(beta_h(maxT_h,nParmSet)) !(MaxT_h,max_parm) - allocate(nR(maxT_h,nParmSet),nRR(maxT_h,nParmSet)) !(maxT_h,max_parm) - allocate(snk(MaxR,MaxT_h,nParmSet,nSlice)) !(MaxR,MaxT_h,max_parm,MaxSlice) -! do i=1,MaxR -! do j=1,MaxT_h -! do k=1,nParmSet -! do l=1,nSlice -! snk(i,j,k,l)=0 -! enddo -! enddo -! enddo -! enddo - - allocate(totraj(maxR,nParmSet)) !(maxR,max_parm) - - allocate(nT_h(nParmSet))!(max_parm) - allocate(replica(nParmSet)) - allocate(umbrella(nParmSet)) - allocate(read_iset(nParmSet)) -! allocate(nT_h(nParmSet)) -!------------------------- -! COMMON.PROT -! common /protein/ - allocate(ntot(nslice)) !(maxslice) -! allocatable :: isampl !(max_parm) -!------------------------- -! COMMON.PROTFILES -! common /protfil/ - allocate(protfiles(maxfile_prot,2,MaxR,MaxT_h,nParmSet)) !(maxfile_prot,2,MaxR,MaxT_h,Max_Parm) - allocate(nfile_bin(MaxR,MaxT_h,nParmSet)) - allocate(nfile_asc(MaxR,MaxT_h,nParmSet)) - allocate(nfile_cx(MaxR,MaxT_h,nParmSet)) - allocate(rec_start(MaxR,MaxT_h,nParmSet)) - allocate(rec_end(MaxR,MaxT_h,nParmSet)) !(MaxR,MaxT_h,Max_Parm) -!------------------------- -! COMMON.OBCINKA -! common /obcinka/ - allocate(time_start_collect(maxR,MaxT_h,nParmSet)) - allocate(time_end_collect(maxR,MaxT_h,nParmSet)) !(maxR,MaxT_h,Max_Parm) -!------------------------- -! COMMON.CONTPAR -! common /contpar/ - allocate(sig_comp(ntyp,ntyp),chi_comp(ntyp,ntyp),& - chip_comp(ntyp,ntyp),sc_cutoff(ntyp,ntyp)) !(ntyp,ntyp) -!------------------------- -! COMMON.PEPTCONT -! common /peptcont/ - allocate(icont_pept_ref(2,maxcont)) !(2,maxcont) -! allocate(ncont_frag_ref()) !(mmaxfrag) -! allocate(icont_frag_ref(2,maxcont)) !(2,maxcont,mmaxfrag) - allocate(isec_ref(nres)) !(maxres) -!------------------------- -! COMMON.VAR -! Angles from experimental structure -! common /varref/ - allocate(vbld_ref(nres),theta_ref(nres),& - phi_ref(nres),alph_ref(nres),omeg_ref(nres)) !(maxres) -!------------------------- - end subroutine alloc_wham_arrays -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- diff --git a/source/wham/wham_calc.F90 b/source/wham/wham_calc.F90 new file mode 100644 index 0000000..08e166c --- /dev/null +++ b/source/wham/wham_calc.F90 @@ -0,0 +1,1259 @@ + module wham_calc +!----------------------------------------------------------------------------- + use io_units + use wham_data +! + use ene_calc +#ifdef MPI + use MPI_data +! include "COMMON.MPI" +#endif + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- + + subroutine WHAMCALC(islice,*) +! Weighed Histogram Analysis Method (WHAM) code +! Written by A. Liwo based on the work of Kumar et al., +! J.Comput.Chem., 13, 1011 (1992) +! +! 2/1/05 Multiple temperatures allowed. +! 2/2/05 Free energies calculated directly from data points +! acc. to Eq. (21) of Kumar et al.; final histograms also +! constructed based on this equation. +! 2/12/05 Multiple parameter sets included +! +! 2/2/05 Parallel version +! use wham_data +! use io_units + use names + use io_base, only:ilen + use energy_data +#ifdef MPI + include "mpif.h" +#endif +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" + integer,parameter :: NGridT=400 + integer,parameter :: MaxBinRms=100,MaxBinRgy=100 + integer,parameter :: MaxHdim=200 +! parameter (MaxHdim=200000) + integer,parameter :: maxinde=200 +#ifdef MPI + integer :: ierror,errcode,status(MPI_STATUS_SIZE) +#endif +! include "COMMON.CONTROL" +! include "COMMON.IOUNITS" +! include "COMMON.FREE" +! include "COMMON.ENERGIES" +! include "COMMON.FFIELD" +! include "COMMON.SBRIDGE" +! include "COMMON.PROT" +! include "COMMON.ENEPS" + integer,parameter :: MaxPoint=MaxStr,& + MaxPointProc=MaxStr_Proc + real(kind=8),parameter :: finorm_max=1.0d0 + real(kind=8) :: potfac,entmin,entmax,expfac,vf + integer :: islice + integer :: i,ii,j,jj,k,kk,l,m,ind,iter,t,tmax,ient,ientmax,iln + integer :: start,end,iharm,ib,iib,nbin1,nbin,nbin_rms,nbin_rgy,& + nbin_rmsrgy,liczbaW,iparm,nFi,indrgy,indrms + integer :: htot(0:MaxHdim),histent(0:2000) + real(kind=8) :: v(MaxPointProc,MaxR,MaxT_h,nParmSet) !(MaxPointProc,MaxR,MaxT_h,Max_Parm) + real(kind=8) :: energia(0:n_ene) +!el real(kind=8) :: energia(0:max_ene) +#ifdef MPI + integer :: tmax_t,upindE_p + real(kind=8) :: fi_p(MaxR,MaxT_h,nParmSet) !(MaxR,MaxT_h,Max_Parm) + real(kind=8),dimension(0:nGridT,nParmSet) :: sumW_p,sumE_p,& + sumEbis_p,sumEsq_p !(0:nGridT,Max_Parm) + real(kind=8),dimension(MaxQ1,0:nGridT,nParmSet) :: sumQ_p,& + sumQsq_p,sumEQ_p,sumEprim_p !(MaxQ1,0:nGridT,Max_Parm) + real(kind=8) :: hfin_p(0:MaxHdim,maxT_h),& + hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH,& + hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) + real(kind=8) :: rgymin_t,rmsmin_t,rgymax_t,rmsmax_t + real(kind=8) :: potEmin_t,entmin_p,entmax_p + integer :: histent_p(0:2000) + logical :: lprint=.true. +#endif + real(kind=8) :: delta_T=1.0d0,iientmax + real(kind=8) :: rgymin,rmsmin,rgymax,rmsmax + real(kind=8),dimension(0:nGridT,nParmSet) :: sumW,sumE,& + sumEsq,sumEprim,sumEbis !(0:NGridT,Max_Parm) + real(kind=8),dimension(MaxQ1,0:nGridT,nParmSet) :: sumQ,& + sumQsq,sumEQ !(MaxQ1,0:NGridT,Max_Parm) + real(kind=8) :: betaT,weight,econstr + real(kind=8) :: fi(MaxR,MaxT_h,nParmSet),& !(MaxR,maxT_h,Max_Parm) + ddW,dd1,dd2,hh,dmin,denom,finorm,avefi,pom,& + hfin(0:MaxHdim,maxT_h),histE(0:maxindE),& + hrmsrgy(0:MaxBinRgy,0:MaxBinRms,maxT_h),& + potEmin,ent,& + hfin_ent(0:MaxHdim),vmax,aux + real(kind=8) :: fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl,& + eprim,ebis,temper,kfac=2.4d0,T0=300.0d0,startGridT=200.0d0,& + eplus,eminus,logfac,tanhT,tt + real(kind=8) :: etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors,& + escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,& + eello_turn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor + + integer :: ind_point(maxpoint),upindE,indE + character(len=16) :: plik + character(len=1) :: licz1 + character(len=2) :: licz2 + character(len=3) :: licz3 + character(len=128) :: nazwa +! integer ilen +! external ilen +!el ientmax=0 +!el ent=0.0d0 + write(licz2,'(bz,i2.2)') islice + nbin1 = 1.0d0/delta + write (iout,'(//80(1h-)/"Solving WHAM equations for slice",& + i2/80(1h-)//)') islice + write (iout,*) "delta",delta," nbin1",nbin1 + write (iout,*) "MaxN",MaxN," MaxQ",MaxQ," MaHdim",MaxHdim + call flush(iout) + dmin=0.0d0 + tmax=0 + potEmin=1.0d10 + rgymin=1.0d10 + rmsmin=1.0d10 + rgymax=0.0d0 + rmsmax=0.0d0 + do t=0,MaxN + htot(t)=0 + enddo +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif + do j=1,nParmSet + if (potE(i,j).le.potEmin) potEmin=potE(i,j) + enddo + if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) + if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) + if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) + if (q(nQ+2,i).gt.rgymax) rgymax=q(nQ+2,i) + ind_point(i)=0 + do j=nQ,1,-1 + ind=(q(j,i)-dmin+1.0d-8)/delta + if (j.eq.1) then + ind_point(i)=ind_point(i)+ind + else + ind_point(i)=ind_point(i)+nbin1**(j-1)*ind + endif +! write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", +! & ind_point(i) + call flush(iout) + if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then + write (iout,*) "Error - index exceeds range for point",i,& + " q=",q(j,i)," ind",ind_point(i) +#ifdef MPI + write (iout,*) "Processor",me1 + call flush(iout) + call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) +#endif + stop + endif + enddo ! j + if (ind_point(i).gt.tmax) tmax=ind_point(i) + htot(ind_point(i))=htot(ind_point(i))+1 +#ifdef DEBUG + write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i),& + " htot",htot(ind_point(i)) + call flush(iout) +#endif + enddo ! i + call flush(iout) + + nbin=nbin1**nQ-1 + write (iout,'(a)') "Numbers of counts in Q bins" + do t=0,tmax + if (htot(t).gt.0) then + write (iout,'(i15,$)') t + liczbaW=t + do j=1,nQ + jj = mod(liczbaW,nbin1) + liczbaW=liczbaW/nbin1 + write (iout,'(i5,$)') jj + enddo + write (iout,'(i8)') htot(t) + endif + enddo + do iparm=1,nParmSet + write (iout,'(a,i3)') "Number of data points for parameter set",& + iparm + write (iout,'(i7,$)') ((snk(m,ib,iparm,islice),m=1,nr(ib,iparm)),& + ib=1,nT_h(iparm)) + write (iout,'(i8)') stot(islice) + write (iout,'(a)') + enddo + call flush(iout) + +#ifdef MPI + call MPI_AllReduce(tmax,tmax_t,1,MPI_INTEGER,MPI_MAX,& + WHAM_COMM,IERROR) + tmax=tmax_t + call MPI_AllReduce(potEmin,potEmin_t,1,MPI_DOUBLE_PRECISION,& + MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rmsmin,rmsmin_t,1,MPI_DOUBLE_PRECISION,& + MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rmsmax,rmsmax_t,1,MPI_DOUBLE_PRECISION,& + MPI_MAX,WHAM_COMM,IERROR) + call MPI_AllReduce(rgymin,rgymin_t,1,MPI_DOUBLE_PRECISION,& + MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rgymax,rgymax_t,1,MPI_DOUBLE_PRECISION,& + MPI_MAX,WHAM_COMM,IERROR) + potEmin=potEmin_t/2 + rgymin=rgymin_t + rgymax=rgymax_t + rmsmin=rmsmin_t + rmsmax=rmsmax_t + write (iout,*) "potEmin",potEmin +#endif + rmsmin=deltrms*dint(rmsmin/deltrms) + rmsmax=deltrms*dint(rmsmax/deltrms) + rgymin=deltrms*dint(rgymin/deltrgy) + rgymax=deltrms*dint(rgymax/deltrgy) + nbin_rms=(rmsmax-rmsmin)/deltrms + nbin_rgy=(rgymax-rgymin)/deltrgy + write (iout,*) "rmsmin",rmsmin," rmsmax",rmsmax," rgymin",rgymin,& + " rgymax",rgymax," nbin_rms",nbin_rms," nbin_rgy",nbin_rgy + nFi=0 + do i=1,nParmSet + do j=1,nT_h(i) + nFi=nFi+nR(j,i) + enddo + enddo + write (iout,*) "nFi",nFi +! Compute the Boltzmann factor corresponing to restrain potentials in different +! simulations. +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +! write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) + do iparm=1,nParmSet +!#ifdef DEBUG + write (iout,'(2i5,21f8.2)') i,iparm,& + (enetb(k,i,iparm),k=1,21) +!#endif + call restore_parm(iparm) +!#ifdef DEBUG + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& + wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& + wtor_d,wsccor,wbond +!#endif + do ib=1,nT_h(iparm) +!el old rascale weights +! +! if (rescale_modeW.eq.1) then +! quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +! quotl=1.0d0 +! kfacl=1.0d0 +! do l=1,5 +! quotl1=quotl +! quotl=quotl*quot +! kfacl=kfacl*kfac +! fT(l)=kfacl/(kfacl-1.0d0+quotl) +! enddo +!#if defined(FUNCTH) +! tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) +! ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +!#elif defined(FUNCT) +! ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +!#else +! ft(6)=1.0d0 +!#endif +! else if (rescale_modeW.eq.2) then +! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +! quotl=1.0d0 +! do l=1,5 +! quotl=quotl*quot +! fT(l)=1.12692801104297249644d0/ & +! dlog(dexp(quotl)+dexp(-quotl)) +! enddo +!#if defined(FUNCTH) +! tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) +! ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +!#elif defined(FUNCT) +! ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +!#else +! ft(6)=1.0d0 +!#endif +! write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft +! else if (rescale_modeW.eq.0) then +! do l=1,6 +! fT(l)=1.0d0 +! enddo +! else +! write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE",& +! rescale_modeW +! call flush(iout) +! return 1 +! endif +! el end old rescale weights + call rescale_weights(1.0d0/(beta_h(ib,iparm)*1.987D-3)) + +! call etot(enetb(0,i,iparm)) + evdw=enetb(1,i,iparm) +! evdw_t=enetb(21,i,iparm) + evdw_t=enetb(20,i,iparm) +#ifdef SCP14 +! evdw2_14=enetb(17,i,iparm) + evdw2_14=enetb(18,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eello_turn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) +! estr=enetb(18,i,iparm) + estr=enetb(17,i,iparm) +! esccor=enetb(19,i,iparm) + esccor=enetb(21,i,iparm) +! edihcnstr=enetb(20,i,iparm) + edihcnstr=enetb(19,i,iparm) +#ifdef DEBUG + write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6),& + evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc,& + etors,etors_d,eello_turn3,eello_turn4,esccor +#endif + +!#ifdef SPLITELE +! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & +! +wvdwpp*evdw1 & +! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & +! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & +! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & +! +ft(2)*wturn3*eello_turn3 & +! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc & +! +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & +! +wbond*estr +!#else +! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & +! +ft(1)*welec*(ees+evdw1) & +! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & +! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & +! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & +! +ft(2)*wturn3*eello_turn3 & +! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr & +! +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & +! +wbond*estr +!#endif + +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees & + +wvdwpp*evdw1 & + +wang*ebe+wtor*etors+wscloc*escloc & + +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & + +wcorr6*ecorr6+wturn4*eello_turn4 & + +wturn3*eello_turn3 & + +wturn6*eello_turn6+wel_loc*eel_loc & + +edihcnstr+wtor_d*etors_d+wsccor*esccor & + +wbond*estr +#else + etot=wsc*evdw+wscp*evdw2 & + +welec*(ees+evdw1) & + +wang*ebe+wtor*etors+wscloc*escloc & + +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & + +wcorr6*ecorr6+wturn4*eello_turn4 & + +wturn3*eello_turn3 & + +wturn6*eello_turn6+wel_loc*eel_loc+edihcnstr & + +wtor_d*etors_d+wsccor*esccor & + +wbond*estr +#endif + +#ifdef DEBUG + write (iout,*) i,iparm,1.0d0/(beta_h(ib,iparm)*1.987D-3),& + etot,potEmin +#endif +#ifdef DEBUG + if (iparm.eq.1 .and. ib.eq.1) then + write (iout,*)"Conformation",i + energia(0)=etot + do k=1,max_ene + energia(k)=enetb(k,i,iparm) + enddo +! call enerprint(energia(0),fT) + call enerprint(energia(0)) + endif +#endif + do kk=1,nR(ib,iparm) + Econstr=0.0d0 + do j=1,nQ + ddW = q(j,i) + Econstr=Econstr+Kh(j,kk,ib,iparm) & + *(ddW-q0(j,kk,ib,iparm))**2 + enddo + v(i,kk,ib,iparm)= & + -beta_h(ib,iparm)*(etot-potEmin+Econstr) +#ifdef DEBUG + write (iout,'(4i5,4e15.5)') i,kk,ib,iparm,& + etot,potEmin,etot-potEmin,v(i,kk,ib,iparm) +#endif + enddo ! kk + enddo ! ib + enddo ! iparm + enddo ! i +! Simple iteration to calculate free energies corresponding to all simulation +! runs. + do iter=1,maxit + +! Compute new free-energy values corresponding to the righ-hand side of the +! equation and their derivatives. + write (iout,*) "------------------------fi" +#ifdef MPI + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + vmax=-1.0d+20 + do i=1,nParmSet + do k=1,nT_h(i) + do l=1,nR(k,i) + vf=v(t,l,k,i)+f(l,k,i) + if (vf.gt.vmax) vmax=vf + enddo + enddo + enddo + denom=0.0d0 + do i=1,nParmSet + do k=1,nT_h(i) + do l=1,nR(k,i) + aux=f(l,k,i)+v(t,l,k,i)-vmax + if (aux.gt.-200.0d0) & + denom=denom+snk(l,k,i,islice)*dexp(aux) + enddo + enddo + enddo + entfac(t)=-dlog(denom)-vmax +#ifdef DEBUG + write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) +#endif + enddo + do iparm=1,nParmSet + do iib=1,nT_h(iparm) + do ii=1,nR(iib,iparm) +#ifdef MPI + fi_p(ii,iib,iparm)=0.0d0 + do t=1,scount(me) + fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) & + +dexp(v(t,ii,iib,iparm)+entfac(t)) +#ifdef DEBUG + write (iout,'(4i5,3e15.5)') t,ii,iib,iparm,& + v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm) +#endif + enddo +#else + fi(ii,iib,iparm)=0.0d0 + do t=1,ntot(islice) + fi(ii,iib,iparm)=fi(ii,iib,iparm) & + +dexp(v(t,ii,iib,iparm)+entfac(t)) + enddo +#endif + enddo ! ii + enddo ! iib + enddo ! iparm + +#ifdef MPI +#ifdef DEBUG + write (iout,*) "fi before MPI_Reduce me",me,' master',master + do iparm=1,nParmSet + do ib=1,nT_h(nparmset) + write (iout,*) "iparm",iparm," ib",ib + write (iout,*) "beta=",beta_h(ib,iparm) + write (iout,'(8e15.5)') (fi_p(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo +#endif + write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet,& + maxR*MaxT_h*nParmSet + write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,& + " WHAM_COMM",WHAM_COMM + call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet,& + MPI_DOUBLE_PRECISION,& + MPI_SUM,Master,WHAM_COMM,IERROR) +#ifdef DEBUG + write (iout,*) "fi after MPI_Reduce nparmset",nparmset + do iparm=1,nParmSet + write (iout,*) "iparm",iparm + do ib=1,nT_h(iparm) + write (iout,*) "beta=",beta_h(ib,iparm) + write (iout,'(8e15.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo +#endif + if (me1.eq.Master) then +#endif + avefi=0.0d0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + fi(i,ib,iparm)=-dlog(fi(i,ib,iparm)) + avefi=avefi+fi(i,ib,iparm) + enddo + enddo + enddo + avefi=avefi/nFi + do iparm=1,nParmSet + write (iout,*) "Parameter set",iparm + do ib =1,nT_h(iparm) + write (iout,*) "beta=",beta_h(ib,iparm) + do i=1,nR(ib,iparm) + fi(i,ib,iparm)=fi(i,ib,iparm)-avefi + enddo + write (iout,'(8f10.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) + write (iout,'(8f10.5)') (f(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo + +! Compute the norm of free-energy increments. + finorm=0.0d0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + finorm=finorm+dabs(fi(i,ib,iparm)-f(i,ib,iparm)) + f(i,ib,iparm)=fi(i,ib,iparm) + enddo + enddo + enddo + + write (iout,*) 'Iteration',iter,' finorm',finorm + +#ifdef MPI + endif + call MPI_Bcast(f(1,1,1),MaxR*MaxT_h*nParmSet,& + MPI_DOUBLE_PRECISION,Master,& + WHAM_COMM,IERROR) + call MPI_Bcast(finorm,1,MPI_DOUBLE_PRECISION,Master,& + WHAM_COMM,IERROR) +#endif +! Exit, if the increment norm is smaller than pre-assigned tolerance. + if (finorm.lt.fimin) then + write (iout,*) 'Iteration converged' + goto 20 + endif + + enddo ! iter + + 20 continue +! Now, put together the histograms from all simulations, in order to get the +! unbiased total histogram. +#ifdef MPI + do t=0,tmax + hfin_ent_p(t)=0.0d0 + enddo +#else + do t=0,tmax + hfin_ent(t)=0.0d0 + enddo +#endif + write (iout,*) "--------------hist" +#ifdef MPI + do iparm=1,nParmSet + do i=0,nGridT + sumW_p(i,iparm)=0.0d0 + sumE_p(i,iparm)=0.0d0 + sumEbis_p(i,iparm)=0.0d0 + sumEsq_p(i,iparm)=0.0d0 + do j=1,nQ+2 + sumQ_p(j,i,iparm)=0.0d0 + sumQsq_p(j,i,iparm)=0.0d0 + sumEQ_p(j,i,iparm)=0.0d0 + enddo + enddo + enddo + upindE_p=0 +#else + do iparm=1,nParmSet + do i=0,nGridT + sumW(i,iparm)=0.0d0 + sumE(i,iparm)=0.0d0 + sumEbis(i,iparm)=0.0d0 + sumEsq(i,iparm)=0.0d0 + do j=1,nQ+2 + sumQ(j,i,iparm)=0.0d0 + sumQsq(j,i,iparm)=0.0d0 + sumEQ(j,i,iparm)=0.0d0 + enddo + enddo + enddo + upindE=0 +#endif +! 8/26/05 entropy distribution +#ifdef MPI + entmin_p=1.0d10 + entmax_p=-1.0d10 + do t=1,scount(me1) +! ent=-dlog(entfac(t)) + ent=entfac(t) + if (ent.lt.entmin_p) entmin_p=ent + if (ent.gt.entmax_p) entmax_p=ent + enddo + write (iout,*) "entmin",entmin_p," entmax",entmax_p +! write (iout,*) "entmin_p",entmin_p," entmax_p",entmax_p + call flush(iout) + call MPI_Allreduce(entmin_p,entmin,1,MPI_DOUBLE_PRECISION,MPI_MIN,& + WHAM_COMM,IERROR) + call MPI_Allreduce(entmax_p,entmax,1,MPI_DOUBLE_PRECISION,MPI_MAX,& + WHAM_COMM,IERROR) + write (iout,*) "entmin",entmin_p," entmax",entmax_p +! write (iout,*) "entmin_p",entmin_p," entmax_p",entmax_p + ientmax=entmax-entmin +!iientmax=entmax-entmin !el +!write (iout,*) "ientmax",ientmax,entmax,entmin +!write (iout,*) "iientmax",iientmax + if (ientmax.gt.2000) ientmax=2000 + write (iout,*) "entmin",entmin," entmax",entmax," ientmax",ientmax + call flush(iout) + do t=1,scount(me1) +! ient=-dlog(entfac(t))-entmin + ient=entfac(t)-entmin + if (ient.le.2000) histent_p(ient)=histent_p(ient)+1 + enddo + call MPI_Allreduce(histent_p(0),histent(0),ientmax+1,MPI_INTEGER,& + MPI_SUM,WHAM_COMM,IERROR) + if (me1.eq.Master) then + write (iout,*) "Entropy histogram" + do i=0,ientmax + write(iout,'(f15.4,i10)') entmin+i,histent(i) + enddo + endif +#else + entmin=1.0d10 + entmax=-1.0d10 + do t=1,ntot(islice) + ent=entfac(t) + if (ent.lt.entmin) entmin=ent + if (ent.gt.entmax) entmax=ent + enddo + ientmax=-dlog(entmax)-entmin + if (ientmax.gt.2000) ientmax=2000 + do t=1,ntot(islice) + ient=entfac(t)-entmin + if (ient.le.2000) histent(ient)=histent(ient)+1 + enddo + write (iout,*) "Entropy histogram" + do i=0,ientmax + write(iout,'(2f15.4)') entmin+i,histent(i) + enddo +#endif + +#ifdef MPI + write (iout,*) "me1",me1," scount",scount(me1) !d + + do iparm=1,nParmSet + +#ifdef MPI + do ib=1,nT_h(iparm) + do t=0,tmax + hfin_p(t,ib)=0.0d0 + enddo + enddo + do i=1,maxindE + histE_p(i)=0.0d0 + enddo +#else + do ib=1,nT_h(iparm) + do t=0,tmax + hfin(t,ib)=0.0d0 + enddo + enddo + do i=1,maxindE + histE(i)=0.0d0 + enddo +#endif + do ib=1,nT_h(iparm) + do i=0,MaxBinRms + do j=0,MaxBinRgy + hrmsrgy(j,i,ib)=0.0d0 +#ifdef MPI + hrmsrgy_p(j,i,ib)=0.0d0 +#endif + enddo + enddo + enddo + + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + ind = ind_point(t) +#ifdef MPI + hfin_ent_p(ind)=hfin_ent_p(ind)+dexp(entfac(t)) +#else + hfin_ent(ind)=hfin_ent(ind)+dexp(entfac(t)) +#endif +! write (iout,'(2i5,20f8.2)') "debug",t,t,(enetb(k,t,iparm),k=1,21) + call restore_parm(iparm) +! evdw=enetb(21,t,iparm) + evdw=enetb(20,t,iparm) + evdw_t=enetb(1,t,iparm) +#ifdef SCP14 +! evdw2_14=enetb(17,t,iparm) + evdw2_14=enetb(18,t,iparm) + evdw2=enetb(2,t,iparm)+evdw2_14 +#else + evdw2=enetb(2,t,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,t,iparm) + evdw1=enetb(16,t,iparm) +#else + ees=enetb(3,t,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,t,iparm) + ecorr5=enetb(5,t,iparm) + ecorr6=enetb(6,t,iparm) + eel_loc=enetb(7,t,iparm) + eello_turn3=enetb(8,t,iparm) + eello_turn4=enetb(9,t,iparm) + eello_turn6=enetb(10,t,iparm) + ebe=enetb(11,t,iparm) + escloc=enetb(12,t,iparm) + etors=enetb(13,t,iparm) + etors_d=enetb(14,t,iparm) + ehpb=enetb(15,t,iparm) +! estr=enetb(18,t,iparm) + estr=enetb(17,t,iparm) +! esccor=enetb(19,t,iparm) + esccor=enetb(21,t,iparm) +! edihcnstr=enetb(20,t,iparm) + edihcnstr=enetb(19,t,iparm) + edihcnstr=0.0d0 + do k=0,nGridT + betaT=startGridT+k*delta_T + temper=betaT +!write(iout,*)"kkkkkkkk",betaT,startGridT,k,delta_T +!d fT=T0/betaT +!d ft=2*T0/(T0+betaT) + if (rescale_modeW.eq.1) then + quot=betaT/T0 + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + denom=kfacl-1.0d0+quotl + fT(l)=kfacl/denom + ftprim(l)=-l*ft(l)*quotl1/(T0*denom) + ftbis(l)=l*kfacl*quotl1* & + (2*l*quotl-(l-1)*denom)/(quot*t0*t0*denom**3) + enddo +#if defined(FUNCTH) + ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & + 320.0d0 + ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) + ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & + /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +#elif defined(FUNCT) + fT(6)=betaT/T0 + ftprim(6)=1.0d0/T0 + ftbis(6)=0.0d0 +#else + fT(6)=1.0d0 + ftprim(6)=0.0d0 + ftbis(6)=0.0d0 +#endif + else if (rescale_modeW.eq.2) then + quot=betaT/T0 + quotl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + eplus=dexp(quotl) + eminus=dexp(-quotl) + logfac=1.0d0/dlog(eplus+eminus) + tanhT=(eplus-eminus)/(eplus+eminus) + fT(l)=1.12692801104297249644d0*logfac + ftprim(l)=-l*quotl1*ft(l)*tanhT*logfac/T0 + ftbis(l)=(l-1)*ftprim(l)/(quot*T0)- & + 2*l*quotl1/T0*logfac* & + (2*l*quotl1*ft(l)/(T0*(eplus+eminus)**2) & + +ftprim(l)*tanhT) + enddo +#if defined(FUNCTH) + ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & + 320.0d0 + ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) + ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & + /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +#elif defined(FUNCT) + fT(6)=betaT/T0 + ftprim(6)=1.0d0/T0 + ftbis(6)=0.0d0 +#else + fT(6)=1.0d0 + ftprim(6)=0.0d0 + ftbis(6)=0.0d0 +#endif + else if (rescale_modeW.eq.0) then + do l=1,5 + fT(l)=1.0d0 + ftprim(l)=0.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE",& + rescale_modeW + call flush(iout) + return 1 + endif +! write (iout,*) "ftprim",ftprim +! write (iout,*) "ftbis",ftbis + betaT=1.0d0/(1.987D-3*betaT) +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & + +wvdwpp*evdw1 & + +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & + +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & + +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & + +ft(2)*wturn3*eello_turn3 & + +ft(5)*wturn6*eello_turn6+ft(2)*wel_loc*eel_loc & + +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & + +wbond*estr + eprim=ftprim(6)*evdw_t+ftprim(1)*welec*ees & + +ftprim(1)*wtor*etors+ & + ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ & + ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ & + ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eello_turn6+ & + ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ & + ftprim(1)*wsccor*esccor + ebis=ftbis(1)*welec*ees+ftbis(1)*wtor*etors+ & + ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ & + ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ & + ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eello_turn6+ & + ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ & + ftbis(1)*wsccor*esccor +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & + +ft(1)*welec*(ees+evdw1) & + +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & + +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & + +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & + +ft(2)*wturn3*eello_turn3 & + +ft(5)*wturn6*eello_turn6+ft(2)*wel_loc*eel_loc+edihcnstr & + +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & + +wbond*estr + eprim=ftprim(6)*evdw_t+ftprim(1)*welec*(ees+evdw1) & + +ftprim(1)*wtor*etors+ & + ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ & + ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ & + ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eello_turn6+ & + ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ & + ftprim(1)*wsccor*esccor + ebis=ftbis(1)*welec*(ees+evdw1)+ftbis(1)*wtor*etors+ & + ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ & + ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ & + ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eello_turn6+ & + ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ & + ftprim(1)*wsccor*esccor +#endif + weight=dexp(-betaT*(etot-potEmin)+entfac(t)) +#ifdef DEBUG + write (iout,*) "iparm",iparm," t",t," betaT",betaT,& + " etot",etot," entfac",entfac(t),& + " weight",weight," ebis",ebis +#endif + etot=etot-temper*eprim +#ifdef MPI + sumW_p(k,iparm)=sumW_p(k,iparm)+weight + sumE_p(k,iparm)=sumE_p(k,iparm)+etot*weight + sumEbis_p(k,iparm)=sumEbis_p(k,iparm)+ebis*weight + sumEsq_p(k,iparm)=sumEsq_p(k,iparm)+etot**2*weight + do j=1,nQ+2 + sumQ_p(j,k,iparm)=sumQ_p(j,k,iparm)+q(j,t)*weight + sumQsq_p(j,k,iparm)=sumQsq_p(j,k,iparm)+q(j,t)**2*weight + sumEQ_p(j,k,iparm)=sumEQ_p(j,k,iparm) & + +etot*q(j,t)*weight + enddo +#else + sumW(k,iparm)=sumW(k,iparm)+weight + sumE(k,iparm)=sumE(k,iparm)+etot*weight + sumEbis(k,iparm)=sumEbis(k,iparm)+ebis*weight + sumEsq(k,iparm)=sumEsq(k,iparm)+etot**2*weight + do j=1,nQ+2 + sumQ(j,k,iparm)=sumQ(j,k,iparm)+q(j,t)*weight + sumQsq(j,k,iparm)=sumQsq(j,k,iparm)+q(j,t)**2*weight + sumEQ(j,k,iparm)=sumEQ(j,k,iparm) & + +etot*q(j,t)*weight + enddo +#endif + enddo + indE = aint(potE(t,iparm)-aint(potEmin)) + if (indE.ge.0 .and. indE.le.maxinde) then + if (indE.gt.upindE_p) upindE_p=indE + histE_p(indE)=histE_p(indE)+dexp(-entfac(t)) + endif +#ifdef MPI + do ib=1,nT_h(iparm) + expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + hfin_p(ind,ib)=hfin_p(ind,ib)+ & + dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + if (rmsrgymap) then + indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) + indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) + hrmsrgy_p(indrgy,indrms,ib)= & + hrmsrgy_p(indrgy,indrms,ib)+expfac + endif + enddo +#else + do ib=1,nT_h(iparm) + expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + hfin(ind,ib)=hfin(ind,ib)+ & + dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + if (rmsrgymap) then + indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) + indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) + hrmsrgy(indrgy,indrms,ib)= & + hrmsrgy(indrgy,indrms,ib)+expfac + endif + enddo +#endif + enddo ! t + do ib=1,nT_h(iparm) + if (histout) call MPI_Reduce(hfin_p(0,ib),hfin(0,ib),nbin,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + if (rmsrgymap) then + call MPI_Reduce(hrmsrgy_p(0,0,ib),hrmsrgy(0,0,ib),& + (MaxBinRgy+1)*(nbin_rms+1),MPI_DOUBLE_PRECISION,MPI_SUM,Master,& + WHAM_COMM,IERROR) + endif + enddo + call MPI_Reduce(upindE_p,upindE,1,& + MPI_INTEGER,MPI_MAX,Master,WHAM_COMM,IERROR) + call MPI_Reduce(histE_p(0),histE(0),maxindE,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + + if (me1.eq.master) then + + if (histout) then + + write (iout,'(6x,$)') + write (iout,'(f20.2,$)') (1.0d0/(1.987D-3*beta_h(ib,iparm)),& + ib=1,nT_h(iparm)) + write (iout,*) + + write (iout,'(/a)') 'Final histograms' + if (histfile) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3//'.hist' + else + histname=prefix(:ilen(prefix))//'.hist' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3// & + '_slice_'//licz2//'.hist' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.hist' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + endif + + do t=0,tmax + liczbaW=t + sumH=0.0d0 + do ib=1,nT_h(iparm) + sumH=sumH+hfin(t,ib) + enddo + if (sumH.gt.0.0d0) then + do j=1,nQ + jj = mod(liczbaW,nbin1) + liczbaW=liczbaW/nbin1 + write (iout,'(f6.3,$)') dmin+(jj+0.5d0)*delta + if (histfile) & + write (ihist,'(f6.3,$)') dmin+(jj+0.5d0)*delta + enddo + do ib=1,nT_h(iparm) + write (iout,'(e20.10,$)') hfin(t,ib) + if (histfile) write (ihist,'(e20.10,$)') hfin(t,ib) + enddo + write (iout,'(i5)') iparm + if (histfile) write (ihist,'(i5)') iparm + endif + enddo + + endif + + if (entfile) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//"_par"//licz3//'.ent' + else + histname=prefix(:ilen(prefix))//'.ent' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'par_'//licz3// & + '_slice_'//licz2//'.ent' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.ent' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + write (ihist,'(a)') "# Microcanonical entropy" + do i=0,upindE + write (ihist,'(f8.0,$)') dint(potEmin)+i + if (histE(i).gt.0.0e0) then + write (ihist,'(f15.5,$)') dlog(histE(i)) + else + write (ihist,'(f15.5,$)') 0.0d0 + endif + enddo + write (ihist,*) + close(ihist) + endif + write (iout,*) "Microcanonical entropy" + do i=0,upindE + write (iout,'(f8.0,$)') dint(potEmin)+i + if (histE(i).gt.0.0e0) then + write (iout,'(f15.5,$)') dlog(histE(i)) + else + write (iout,'(f15.5,$)') 0.0d0 + endif + write (iout,*) + enddo + if (rmsrgymap) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3//'.rmsrgy' + else + histname=prefix(:ilen(prefix))//'.rmsrgy' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3// & + '_slice_'//licz2//'.rmsrgy' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.rmsrgy' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + do i=0,nbin_rms + do j=0,nbin_rgy + write(ihist,'(2f8.2,$)') & + rgymin+deltrgy*j,rmsmin+deltrms*i + do ib=1,nT_h(iparm) + if (hrmsrgy(j,i,ib).gt.0.0d0) then + write(ihist,'(e14.5,$)') & + -dlog(hrmsrgy(j,i,ib))/beta_h(ib,iparm) & + +potEmin + else + write(ihist,'(e14.5,$)') 1.0d6 + endif + enddo + write (ihist,'(i2)') iparm + enddo + enddo + close(ihist) + endif + endif + enddo ! iparm +#ifdef MPI + call MPI_Reduce(hfin_ent_p(0),hfin_ent(0),nbin,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumW_p(0,1),sumW(0,1),(nGridT+1)*nParmSet,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumE_p(0,1),sumE(0,1),(nGridT+1)*nParmSet,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumEbis_p(0,1),sumEbis(0,1),(nGridT+1)*nParmSet,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumEsq_p(0,1),sumEsq(0,1),(nGridT+1)*nParmSet,& + MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumQ_p(1,0,1),sumQ(1,0,1),& + MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master,& + WHAM_COMM,IERROR) + call MPI_Reduce(sumQsq_p(1,0,1),sumQsq(1,0,1),& + MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master,& + WHAM_COMM,IERROR) + call MPI_Reduce(sumEQ_p(1,0,1),sumEQ(1,0,1),& + MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master,& + WHAM_COMM,IERROR) + if (me.eq.master) then +#endif + write (iout,'(/a)') 'Thermal characteristics of folding' + if (nslice.eq.1) then + nazwa=prefix + else + nazwa=prefix(:ilen(prefix))//"_slice_"//licz2 + endif + iln=ilen(nazwa) + if (nparmset.eq.1 .and. .not.separate_parset) then + nazwa=nazwa(:iln)//".thermal" + else if (nparmset.eq.1 .and. separate_parset) then + write(licz3,"(bz,i3.3)") myparm + nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" + endif + do iparm=1,nParmSet + if (nparmset.gt.1) then + write(licz3,"(bz,i3.3)") iparm + nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" + endif + open(34,file=nazwa) + if (separate_parset) then + write (iout,'(a,i3)') "Parameter set",myparm + else + write (iout,'(a,i3)') "Parameter set",iparm + endif + do i=0,NGridT + sumE(i,iparm)=sumE(i,iparm)/sumW(i,iparm) + sumEbis(i,iparm)=(startGridT+i*delta_T)*sumEbis(i,iparm)/ & + sumW(i,iparm) + sumEsq(i,iparm)=(sumEsq(i,iparm)/sumW(i,iparm) & + -sumE(i,iparm)**2)/(1.987D-3*(startGridT+i*delta_T)**2) + do j=1,nQ+2 + sumQ(j,i,iparm)=sumQ(j,i,iparm)/sumW(i,iparm) + sumQsq(j,i,iparm)=sumQsq(j,i,iparm)/sumW(i,iparm) & + -sumQ(j,i,iparm)**2 + sumEQ(j,i,iparm)=sumEQ(j,i,iparm)/sumW(i,iparm) & + -sumQ(j,i,iparm)*sumE(i,iparm) + enddo + sumW(i,iparm)=-dlog(sumW(i,iparm))*(1.987D-3* & + (startGridT+i*delta_T))+potEmin + write (iout,'(f7.1,2f15.5,$)') startGridT+i*delta_T,& + sumW(i,iparm),sumE(i,iparm) + write (iout,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) + write (iout,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm),& + (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) + write (iout,*) + write (34,'(f7.1,2f15.5,$)') startGridT+i*delta_T,& + sumW(i,iparm),sumE(i,iparm) + write (34,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) + write (34,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm),& + (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) + write (34,*) + call flush(34) + enddo + close(34) + enddo + if (histout) then + do t=0,tmax + if (hfin_ent(t).gt.0.0d0) then + liczbaW=t + jj = mod(liczbaW,nbin1) + write (iout,'(f6.3,e20.10," ent")') dmin+(jj+0.5d0)*delta,& + hfin_ent(t) + if (histfile) write (ihist,'(f6.3,e20.10," ent")') & + dmin+(jj+0.5d0)*delta,& + hfin_ent(t) + endif + enddo + if (histfile) close(ihist) + endif + +#ifdef ZSCORE +! Write data for zscore + if (nslice.eq.1) then + zscname=prefix(:ilen(prefix))//".zsc" + else + zscname=prefix(:ilen(prefix))//"_slice_"//licz2//".zsc" + endif +#if defined(AIX) || defined(PGI) + open (izsc,file=prefix(:ilen(prefix))//'.zsc',position='append') +#else + open (izsc,file=prefix(:ilen(prefix))//'.zsc',access='append') +#endif + write (izsc,'("NQ=",i1," NPARM=",i1)') nQ,nParmSet + do iparm=1,nParmSet + write (izsc,'("NT=",i1)') nT_h(iparm) + do ib=1,nT_h(iparm) + write (izsc,'("TEMP=",f6.1," NR=",i2," SNK=",$)') & + 1.0d0/(beta_h(ib,iparm)*1.987D-3),nR(ib,iparm) + jj = min0(nR(ib,iparm),7) + write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=1,jj) + write (izsc,'(a1,$)') (" ",i=22+8*jj+1,79) + write (izsc,'("&")') + if (nR(ib,iparm).gt.7) then + do ii=8,nR(ib,iparm),9 + jj = min0(nR(ib,iparm),ii+8) + write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=ii,jj) + write (izsc,'(a1,$') (" ",i=(jj-ii+1)*8+1,79) + write (izsc,'("&")') + enddo + endif + write (izsc,'("FI=",$)') + jj=min0(nR(ib,iparm),7) + write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=1,jj) + write (izsc,'(a1,$)') (" ",i=3+10*jj+1,79) + write (izsc,'("&")') + if (nR(ib,iparm).gt.7) then + do ii=8,nR(ib,iparm),9 + jj = min0(nR(ib,iparm),ii+8) + write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=ii,jj) + if (jj.eq.nR(ib,iparm)) then + write (izsc,*) + else + write (izsc,'(a1,$)') (" ",i=10*(jj-ii+1)+1,79) + write (izsc,'(t80,"&")') + endif + enddo + endif + do i=1,nR(ib,iparm) + write (izsc,'("KH=",$)') + write (izsc,'(f7.2,$)') (Kh(j,i,ib,iparm),j=1,nQ) + write (izsc,'(" Q0=",$)') + write (izsc,'(f7.5,$)') (q0(j,i,ib,iparm),j=1,nQ) + write (izsc,*) + enddo + enddo + enddo + close(izsc) +#endif +#ifdef MPI + endif +#endif + return + end subroutine WHAMCALC +!----------------------------------------------------------------------------- + end module wham_calc + diff --git a/source/wham/wham_calc.f90 b/source/wham/wham_calc.f90 deleted file mode 100644 index 08e166c..0000000 --- a/source/wham/wham_calc.f90 +++ /dev/null @@ -1,1259 +0,0 @@ - module wham_calc -!----------------------------------------------------------------------------- - use io_units - use wham_data -! - use ene_calc -#ifdef MPI - use MPI_data -! include "COMMON.MPI" -#endif - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- - - subroutine WHAMCALC(islice,*) -! Weighed Histogram Analysis Method (WHAM) code -! Written by A. Liwo based on the work of Kumar et al., -! J.Comput.Chem., 13, 1011 (1992) -! -! 2/1/05 Multiple temperatures allowed. -! 2/2/05 Free energies calculated directly from data points -! acc. to Eq. (21) of Kumar et al.; final histograms also -! constructed based on this equation. -! 2/12/05 Multiple parameter sets included -! -! 2/2/05 Parallel version -! use wham_data -! use io_units - use names - use io_base, only:ilen - use energy_data -#ifdef MPI - include "mpif.h" -#endif -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" - integer,parameter :: NGridT=400 - integer,parameter :: MaxBinRms=100,MaxBinRgy=100 - integer,parameter :: MaxHdim=200 -! parameter (MaxHdim=200000) - integer,parameter :: maxinde=200 -#ifdef MPI - integer :: ierror,errcode,status(MPI_STATUS_SIZE) -#endif -! include "COMMON.CONTROL" -! include "COMMON.IOUNITS" -! include "COMMON.FREE" -! include "COMMON.ENERGIES" -! include "COMMON.FFIELD" -! include "COMMON.SBRIDGE" -! include "COMMON.PROT" -! include "COMMON.ENEPS" - integer,parameter :: MaxPoint=MaxStr,& - MaxPointProc=MaxStr_Proc - real(kind=8),parameter :: finorm_max=1.0d0 - real(kind=8) :: potfac,entmin,entmax,expfac,vf - integer :: islice - integer :: i,ii,j,jj,k,kk,l,m,ind,iter,t,tmax,ient,ientmax,iln - integer :: start,end,iharm,ib,iib,nbin1,nbin,nbin_rms,nbin_rgy,& - nbin_rmsrgy,liczbaW,iparm,nFi,indrgy,indrms - integer :: htot(0:MaxHdim),histent(0:2000) - real(kind=8) :: v(MaxPointProc,MaxR,MaxT_h,nParmSet) !(MaxPointProc,MaxR,MaxT_h,Max_Parm) - real(kind=8) :: energia(0:n_ene) -!el real(kind=8) :: energia(0:max_ene) -#ifdef MPI - integer :: tmax_t,upindE_p - real(kind=8) :: fi_p(MaxR,MaxT_h,nParmSet) !(MaxR,MaxT_h,Max_Parm) - real(kind=8),dimension(0:nGridT,nParmSet) :: sumW_p,sumE_p,& - sumEbis_p,sumEsq_p !(0:nGridT,Max_Parm) - real(kind=8),dimension(MaxQ1,0:nGridT,nParmSet) :: sumQ_p,& - sumQsq_p,sumEQ_p,sumEprim_p !(MaxQ1,0:nGridT,Max_Parm) - real(kind=8) :: hfin_p(0:MaxHdim,maxT_h),& - hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH,& - hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) - real(kind=8) :: rgymin_t,rmsmin_t,rgymax_t,rmsmax_t - real(kind=8) :: potEmin_t,entmin_p,entmax_p - integer :: histent_p(0:2000) - logical :: lprint=.true. -#endif - real(kind=8) :: delta_T=1.0d0,iientmax - real(kind=8) :: rgymin,rmsmin,rgymax,rmsmax - real(kind=8),dimension(0:nGridT,nParmSet) :: sumW,sumE,& - sumEsq,sumEprim,sumEbis !(0:NGridT,Max_Parm) - real(kind=8),dimension(MaxQ1,0:nGridT,nParmSet) :: sumQ,& - sumQsq,sumEQ !(MaxQ1,0:NGridT,Max_Parm) - real(kind=8) :: betaT,weight,econstr - real(kind=8) :: fi(MaxR,MaxT_h,nParmSet),& !(MaxR,maxT_h,Max_Parm) - ddW,dd1,dd2,hh,dmin,denom,finorm,avefi,pom,& - hfin(0:MaxHdim,maxT_h),histE(0:maxindE),& - hrmsrgy(0:MaxBinRgy,0:MaxBinRms,maxT_h),& - potEmin,ent,& - hfin_ent(0:MaxHdim),vmax,aux - real(kind=8) :: fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl,& - eprim,ebis,temper,kfac=2.4d0,T0=300.0d0,startGridT=200.0d0,& - eplus,eminus,logfac,tanhT,tt - real(kind=8) :: etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors,& - escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,& - eello_turn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor - - integer :: ind_point(maxpoint),upindE,indE - character(len=16) :: plik - character(len=1) :: licz1 - character(len=2) :: licz2 - character(len=3) :: licz3 - character(len=128) :: nazwa -! integer ilen -! external ilen -!el ientmax=0 -!el ent=0.0d0 - write(licz2,'(bz,i2.2)') islice - nbin1 = 1.0d0/delta - write (iout,'(//80(1h-)/"Solving WHAM equations for slice",& - i2/80(1h-)//)') islice - write (iout,*) "delta",delta," nbin1",nbin1 - write (iout,*) "MaxN",MaxN," MaxQ",MaxQ," MaHdim",MaxHdim - call flush(iout) - dmin=0.0d0 - tmax=0 - potEmin=1.0d10 - rgymin=1.0d10 - rmsmin=1.0d10 - rgymax=0.0d0 - rmsmax=0.0d0 - do t=0,MaxN - htot(t)=0 - enddo -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif - do j=1,nParmSet - if (potE(i,j).le.potEmin) potEmin=potE(i,j) - enddo - if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) - if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) - if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) - if (q(nQ+2,i).gt.rgymax) rgymax=q(nQ+2,i) - ind_point(i)=0 - do j=nQ,1,-1 - ind=(q(j,i)-dmin+1.0d-8)/delta - if (j.eq.1) then - ind_point(i)=ind_point(i)+ind - else - ind_point(i)=ind_point(i)+nbin1**(j-1)*ind - endif -! write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", -! & ind_point(i) - call flush(iout) - if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then - write (iout,*) "Error - index exceeds range for point",i,& - " q=",q(j,i)," ind",ind_point(i) -#ifdef MPI - write (iout,*) "Processor",me1 - call flush(iout) - call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) -#endif - stop - endif - enddo ! j - if (ind_point(i).gt.tmax) tmax=ind_point(i) - htot(ind_point(i))=htot(ind_point(i))+1 -#ifdef DEBUG - write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i),& - " htot",htot(ind_point(i)) - call flush(iout) -#endif - enddo ! i - call flush(iout) - - nbin=nbin1**nQ-1 - write (iout,'(a)') "Numbers of counts in Q bins" - do t=0,tmax - if (htot(t).gt.0) then - write (iout,'(i15,$)') t - liczbaW=t - do j=1,nQ - jj = mod(liczbaW,nbin1) - liczbaW=liczbaW/nbin1 - write (iout,'(i5,$)') jj - enddo - write (iout,'(i8)') htot(t) - endif - enddo - do iparm=1,nParmSet - write (iout,'(a,i3)') "Number of data points for parameter set",& - iparm - write (iout,'(i7,$)') ((snk(m,ib,iparm,islice),m=1,nr(ib,iparm)),& - ib=1,nT_h(iparm)) - write (iout,'(i8)') stot(islice) - write (iout,'(a)') - enddo - call flush(iout) - -#ifdef MPI - call MPI_AllReduce(tmax,tmax_t,1,MPI_INTEGER,MPI_MAX,& - WHAM_COMM,IERROR) - tmax=tmax_t - call MPI_AllReduce(potEmin,potEmin_t,1,MPI_DOUBLE_PRECISION,& - MPI_MIN,WHAM_COMM,IERROR) - call MPI_AllReduce(rmsmin,rmsmin_t,1,MPI_DOUBLE_PRECISION,& - MPI_MIN,WHAM_COMM,IERROR) - call MPI_AllReduce(rmsmax,rmsmax_t,1,MPI_DOUBLE_PRECISION,& - MPI_MAX,WHAM_COMM,IERROR) - call MPI_AllReduce(rgymin,rgymin_t,1,MPI_DOUBLE_PRECISION,& - MPI_MIN,WHAM_COMM,IERROR) - call MPI_AllReduce(rgymax,rgymax_t,1,MPI_DOUBLE_PRECISION,& - MPI_MAX,WHAM_COMM,IERROR) - potEmin=potEmin_t/2 - rgymin=rgymin_t - rgymax=rgymax_t - rmsmin=rmsmin_t - rmsmax=rmsmax_t - write (iout,*) "potEmin",potEmin -#endif - rmsmin=deltrms*dint(rmsmin/deltrms) - rmsmax=deltrms*dint(rmsmax/deltrms) - rgymin=deltrms*dint(rgymin/deltrgy) - rgymax=deltrms*dint(rgymax/deltrgy) - nbin_rms=(rmsmax-rmsmin)/deltrms - nbin_rgy=(rgymax-rgymin)/deltrgy - write (iout,*) "rmsmin",rmsmin," rmsmax",rmsmax," rgymin",rgymin,& - " rgymax",rgymax," nbin_rms",nbin_rms," nbin_rgy",nbin_rgy - nFi=0 - do i=1,nParmSet - do j=1,nT_h(i) - nFi=nFi+nR(j,i) - enddo - enddo - write (iout,*) "nFi",nFi -! Compute the Boltzmann factor corresponing to restrain potentials in different -! simulations. -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif -! write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) - do iparm=1,nParmSet -!#ifdef DEBUG - write (iout,'(2i5,21f8.2)') i,iparm,& - (enetb(k,i,iparm),k=1,21) -!#endif - call restore_parm(iparm) -!#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,& - wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,& - wtor_d,wsccor,wbond -!#endif - do ib=1,nT_h(iparm) -!el old rascale weights -! -! if (rescale_modeW.eq.1) then -! quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) -! quotl=1.0d0 -! kfacl=1.0d0 -! do l=1,5 -! quotl1=quotl -! quotl=quotl*quot -! kfacl=kfacl*kfac -! fT(l)=kfacl/(kfacl-1.0d0+quotl) -! enddo -!#if defined(FUNCTH) -! tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) -! ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 -!#elif defined(FUNCT) -! ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) -!#else -! ft(6)=1.0d0 -!#endif -! else if (rescale_modeW.eq.2) then -! quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) -! quotl=1.0d0 -! do l=1,5 -! quotl=quotl*quot -! fT(l)=1.12692801104297249644d0/ & -! dlog(dexp(quotl)+dexp(-quotl)) -! enddo -!#if defined(FUNCTH) -! tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) -! ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 -!#elif defined(FUNCT) -! ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) -!#else -! ft(6)=1.0d0 -!#endif -! write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft -! else if (rescale_modeW.eq.0) then -! do l=1,6 -! fT(l)=1.0d0 -! enddo -! else -! write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE",& -! rescale_modeW -! call flush(iout) -! return 1 -! endif -! el end old rescale weights - call rescale_weights(1.0d0/(beta_h(ib,iparm)*1.987D-3)) - -! call etot(enetb(0,i,iparm)) - evdw=enetb(1,i,iparm) -! evdw_t=enetb(21,i,iparm) - evdw_t=enetb(20,i,iparm) -#ifdef SCP14 -! evdw2_14=enetb(17,i,iparm) - evdw2_14=enetb(18,i,iparm) - evdw2=enetb(2,i,iparm)+evdw2_14 -#else - evdw2=enetb(2,i,iparm) - evdw2_14=0.0d0 -#endif -#ifdef SPLITELE - ees=enetb(3,i,iparm) - evdw1=enetb(16,i,iparm) -#else - ees=enetb(3,i,iparm) - evdw1=0.0d0 -#endif - ecorr=enetb(4,i,iparm) - ecorr5=enetb(5,i,iparm) - ecorr6=enetb(6,i,iparm) - eel_loc=enetb(7,i,iparm) - eello_turn3=enetb(8,i,iparm) - eello_turn4=enetb(9,i,iparm) - eello_turn6=enetb(10,i,iparm) - ebe=enetb(11,i,iparm) - escloc=enetb(12,i,iparm) - etors=enetb(13,i,iparm) - etors_d=enetb(14,i,iparm) - ehpb=enetb(15,i,iparm) -! estr=enetb(18,i,iparm) - estr=enetb(17,i,iparm) -! esccor=enetb(19,i,iparm) - esccor=enetb(21,i,iparm) -! edihcnstr=enetb(20,i,iparm) - edihcnstr=enetb(19,i,iparm) -#ifdef DEBUG - write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6),& - evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc,& - etors,etors_d,eello_turn3,eello_turn4,esccor -#endif - -!#ifdef SPLITELE -! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & -! +wvdwpp*evdw1 & -! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & -! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & -! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & -! +ft(2)*wturn3*eello_turn3 & -! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc & -! +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & -! +wbond*estr -!#else -! etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & -! +ft(1)*welec*(ees+evdw1) & -! +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & -! +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & -! +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & -! +ft(2)*wturn3*eello_turn3 & -! +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr & -! +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & -! +wbond*estr -!#endif - -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees & - +wvdwpp*evdw1 & - +wang*ebe+wtor*etors+wscloc*escloc & - +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & - +wcorr6*ecorr6+wturn4*eello_turn4 & - +wturn3*eello_turn3 & - +wturn6*eello_turn6+wel_loc*eel_loc & - +edihcnstr+wtor_d*etors_d+wsccor*esccor & - +wbond*estr -#else - etot=wsc*evdw+wscp*evdw2 & - +welec*(ees+evdw1) & - +wang*ebe+wtor*etors+wscloc*escloc & - +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 & - +wcorr6*ecorr6+wturn4*eello_turn4 & - +wturn3*eello_turn3 & - +wturn6*eello_turn6+wel_loc*eel_loc+edihcnstr & - +wtor_d*etors_d+wsccor*esccor & - +wbond*estr -#endif - -#ifdef DEBUG - write (iout,*) i,iparm,1.0d0/(beta_h(ib,iparm)*1.987D-3),& - etot,potEmin -#endif -#ifdef DEBUG - if (iparm.eq.1 .and. ib.eq.1) then - write (iout,*)"Conformation",i - energia(0)=etot - do k=1,max_ene - energia(k)=enetb(k,i,iparm) - enddo -! call enerprint(energia(0),fT) - call enerprint(energia(0)) - endif -#endif - do kk=1,nR(ib,iparm) - Econstr=0.0d0 - do j=1,nQ - ddW = q(j,i) - Econstr=Econstr+Kh(j,kk,ib,iparm) & - *(ddW-q0(j,kk,ib,iparm))**2 - enddo - v(i,kk,ib,iparm)= & - -beta_h(ib,iparm)*(etot-potEmin+Econstr) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') i,kk,ib,iparm,& - etot,potEmin,etot-potEmin,v(i,kk,ib,iparm) -#endif - enddo ! kk - enddo ! ib - enddo ! iparm - enddo ! i -! Simple iteration to calculate free energies corresponding to all simulation -! runs. - do iter=1,maxit - -! Compute new free-energy values corresponding to the righ-hand side of the -! equation and their derivatives. - write (iout,*) "------------------------fi" -#ifdef MPI - do t=1,scount(me1) -#else - do t=1,ntot(islice) -#endif - vmax=-1.0d+20 - do i=1,nParmSet - do k=1,nT_h(i) - do l=1,nR(k,i) - vf=v(t,l,k,i)+f(l,k,i) - if (vf.gt.vmax) vmax=vf - enddo - enddo - enddo - denom=0.0d0 - do i=1,nParmSet - do k=1,nT_h(i) - do l=1,nR(k,i) - aux=f(l,k,i)+v(t,l,k,i)-vmax - if (aux.gt.-200.0d0) & - denom=denom+snk(l,k,i,islice)*dexp(aux) - enddo - enddo - enddo - entfac(t)=-dlog(denom)-vmax -#ifdef DEBUG - write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) -#endif - enddo - do iparm=1,nParmSet - do iib=1,nT_h(iparm) - do ii=1,nR(iib,iparm) -#ifdef MPI - fi_p(ii,iib,iparm)=0.0d0 - do t=1,scount(me) - fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) & - +dexp(v(t,ii,iib,iparm)+entfac(t)) -#ifdef DEBUG - write (iout,'(4i5,3e15.5)') t,ii,iib,iparm,& - v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm) -#endif - enddo -#else - fi(ii,iib,iparm)=0.0d0 - do t=1,ntot(islice) - fi(ii,iib,iparm)=fi(ii,iib,iparm) & - +dexp(v(t,ii,iib,iparm)+entfac(t)) - enddo -#endif - enddo ! ii - enddo ! iib - enddo ! iparm - -#ifdef MPI -#ifdef DEBUG - write (iout,*) "fi before MPI_Reduce me",me,' master',master - do iparm=1,nParmSet - do ib=1,nT_h(nparmset) - write (iout,*) "iparm",iparm," ib",ib - write (iout,*) "beta=",beta_h(ib,iparm) - write (iout,'(8e15.5)') (fi_p(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo -#endif - write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet,& - maxR*MaxT_h*nParmSet - write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,& - " WHAM_COMM",WHAM_COMM - call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet,& - MPI_DOUBLE_PRECISION,& - MPI_SUM,Master,WHAM_COMM,IERROR) -#ifdef DEBUG - write (iout,*) "fi after MPI_Reduce nparmset",nparmset - do iparm=1,nParmSet - write (iout,*) "iparm",iparm - do ib=1,nT_h(iparm) - write (iout,*) "beta=",beta_h(ib,iparm) - write (iout,'(8e15.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo -#endif - if (me1.eq.Master) then -#endif - avefi=0.0d0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - fi(i,ib,iparm)=-dlog(fi(i,ib,iparm)) - avefi=avefi+fi(i,ib,iparm) - enddo - enddo - enddo - avefi=avefi/nFi - do iparm=1,nParmSet - write (iout,*) "Parameter set",iparm - do ib =1,nT_h(iparm) - write (iout,*) "beta=",beta_h(ib,iparm) - do i=1,nR(ib,iparm) - fi(i,ib,iparm)=fi(i,ib,iparm)-avefi - enddo - write (iout,'(8f10.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) - write (iout,'(8f10.5)') (f(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo - -! Compute the norm of free-energy increments. - finorm=0.0d0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - finorm=finorm+dabs(fi(i,ib,iparm)-f(i,ib,iparm)) - f(i,ib,iparm)=fi(i,ib,iparm) - enddo - enddo - enddo - - write (iout,*) 'Iteration',iter,' finorm',finorm - -#ifdef MPI - endif - call MPI_Bcast(f(1,1,1),MaxR*MaxT_h*nParmSet,& - MPI_DOUBLE_PRECISION,Master,& - WHAM_COMM,IERROR) - call MPI_Bcast(finorm,1,MPI_DOUBLE_PRECISION,Master,& - WHAM_COMM,IERROR) -#endif -! Exit, if the increment norm is smaller than pre-assigned tolerance. - if (finorm.lt.fimin) then - write (iout,*) 'Iteration converged' - goto 20 - endif - - enddo ! iter - - 20 continue -! Now, put together the histograms from all simulations, in order to get the -! unbiased total histogram. -#ifdef MPI - do t=0,tmax - hfin_ent_p(t)=0.0d0 - enddo -#else - do t=0,tmax - hfin_ent(t)=0.0d0 - enddo -#endif - write (iout,*) "--------------hist" -#ifdef MPI - do iparm=1,nParmSet - do i=0,nGridT - sumW_p(i,iparm)=0.0d0 - sumE_p(i,iparm)=0.0d0 - sumEbis_p(i,iparm)=0.0d0 - sumEsq_p(i,iparm)=0.0d0 - do j=1,nQ+2 - sumQ_p(j,i,iparm)=0.0d0 - sumQsq_p(j,i,iparm)=0.0d0 - sumEQ_p(j,i,iparm)=0.0d0 - enddo - enddo - enddo - upindE_p=0 -#else - do iparm=1,nParmSet - do i=0,nGridT - sumW(i,iparm)=0.0d0 - sumE(i,iparm)=0.0d0 - sumEbis(i,iparm)=0.0d0 - sumEsq(i,iparm)=0.0d0 - do j=1,nQ+2 - sumQ(j,i,iparm)=0.0d0 - sumQsq(j,i,iparm)=0.0d0 - sumEQ(j,i,iparm)=0.0d0 - enddo - enddo - enddo - upindE=0 -#endif -! 8/26/05 entropy distribution -#ifdef MPI - entmin_p=1.0d10 - entmax_p=-1.0d10 - do t=1,scount(me1) -! ent=-dlog(entfac(t)) - ent=entfac(t) - if (ent.lt.entmin_p) entmin_p=ent - if (ent.gt.entmax_p) entmax_p=ent - enddo - write (iout,*) "entmin",entmin_p," entmax",entmax_p -! write (iout,*) "entmin_p",entmin_p," entmax_p",entmax_p - call flush(iout) - call MPI_Allreduce(entmin_p,entmin,1,MPI_DOUBLE_PRECISION,MPI_MIN,& - WHAM_COMM,IERROR) - call MPI_Allreduce(entmax_p,entmax,1,MPI_DOUBLE_PRECISION,MPI_MAX,& - WHAM_COMM,IERROR) - write (iout,*) "entmin",entmin_p," entmax",entmax_p -! write (iout,*) "entmin_p",entmin_p," entmax_p",entmax_p - ientmax=entmax-entmin -!iientmax=entmax-entmin !el -!write (iout,*) "ientmax",ientmax,entmax,entmin -!write (iout,*) "iientmax",iientmax - if (ientmax.gt.2000) ientmax=2000 - write (iout,*) "entmin",entmin," entmax",entmax," ientmax",ientmax - call flush(iout) - do t=1,scount(me1) -! ient=-dlog(entfac(t))-entmin - ient=entfac(t)-entmin - if (ient.le.2000) histent_p(ient)=histent_p(ient)+1 - enddo - call MPI_Allreduce(histent_p(0),histent(0),ientmax+1,MPI_INTEGER,& - MPI_SUM,WHAM_COMM,IERROR) - if (me1.eq.Master) then - write (iout,*) "Entropy histogram" - do i=0,ientmax - write(iout,'(f15.4,i10)') entmin+i,histent(i) - enddo - endif -#else - entmin=1.0d10 - entmax=-1.0d10 - do t=1,ntot(islice) - ent=entfac(t) - if (ent.lt.entmin) entmin=ent - if (ent.gt.entmax) entmax=ent - enddo - ientmax=-dlog(entmax)-entmin - if (ientmax.gt.2000) ientmax=2000 - do t=1,ntot(islice) - ient=entfac(t)-entmin - if (ient.le.2000) histent(ient)=histent(ient)+1 - enddo - write (iout,*) "Entropy histogram" - do i=0,ientmax - write(iout,'(2f15.4)') entmin+i,histent(i) - enddo -#endif - -#ifdef MPI - write (iout,*) "me1",me1," scount",scount(me1) !d - - do iparm=1,nParmSet - -#ifdef MPI - do ib=1,nT_h(iparm) - do t=0,tmax - hfin_p(t,ib)=0.0d0 - enddo - enddo - do i=1,maxindE - histE_p(i)=0.0d0 - enddo -#else - do ib=1,nT_h(iparm) - do t=0,tmax - hfin(t,ib)=0.0d0 - enddo - enddo - do i=1,maxindE - histE(i)=0.0d0 - enddo -#endif - do ib=1,nT_h(iparm) - do i=0,MaxBinRms - do j=0,MaxBinRgy - hrmsrgy(j,i,ib)=0.0d0 -#ifdef MPI - hrmsrgy_p(j,i,ib)=0.0d0 -#endif - enddo - enddo - enddo - - do t=1,scount(me1) -#else - do t=1,ntot(islice) -#endif - ind = ind_point(t) -#ifdef MPI - hfin_ent_p(ind)=hfin_ent_p(ind)+dexp(entfac(t)) -#else - hfin_ent(ind)=hfin_ent(ind)+dexp(entfac(t)) -#endif -! write (iout,'(2i5,20f8.2)') "debug",t,t,(enetb(k,t,iparm),k=1,21) - call restore_parm(iparm) -! evdw=enetb(21,t,iparm) - evdw=enetb(20,t,iparm) - evdw_t=enetb(1,t,iparm) -#ifdef SCP14 -! evdw2_14=enetb(17,t,iparm) - evdw2_14=enetb(18,t,iparm) - evdw2=enetb(2,t,iparm)+evdw2_14 -#else - evdw2=enetb(2,t,iparm) - evdw2_14=0.0d0 -#endif -#ifdef SPLITELE - ees=enetb(3,t,iparm) - evdw1=enetb(16,t,iparm) -#else - ees=enetb(3,t,iparm) - evdw1=0.0d0 -#endif - ecorr=enetb(4,t,iparm) - ecorr5=enetb(5,t,iparm) - ecorr6=enetb(6,t,iparm) - eel_loc=enetb(7,t,iparm) - eello_turn3=enetb(8,t,iparm) - eello_turn4=enetb(9,t,iparm) - eello_turn6=enetb(10,t,iparm) - ebe=enetb(11,t,iparm) - escloc=enetb(12,t,iparm) - etors=enetb(13,t,iparm) - etors_d=enetb(14,t,iparm) - ehpb=enetb(15,t,iparm) -! estr=enetb(18,t,iparm) - estr=enetb(17,t,iparm) -! esccor=enetb(19,t,iparm) - esccor=enetb(21,t,iparm) -! edihcnstr=enetb(20,t,iparm) - edihcnstr=enetb(19,t,iparm) - edihcnstr=0.0d0 - do k=0,nGridT - betaT=startGridT+k*delta_T - temper=betaT -!write(iout,*)"kkkkkkkk",betaT,startGridT,k,delta_T -!d fT=T0/betaT -!d ft=2*T0/(T0+betaT) - if (rescale_modeW.eq.1) then - quot=betaT/T0 - quotl=1.0d0 - kfacl=1.0d0 - do l=1,5 - quotl1=quotl - quotl=quotl*quot - kfacl=kfacl*kfac - denom=kfacl-1.0d0+quotl - fT(l)=kfacl/denom - ftprim(l)=-l*ft(l)*quotl1/(T0*denom) - ftbis(l)=l*kfacl*quotl1* & - (2*l*quotl-(l-1)*denom)/(quot*t0*t0*denom**3) - enddo -#if defined(FUNCTH) - ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & - 320.0d0 - ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) - ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & - /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) -#elif defined(FUNCT) - fT(6)=betaT/T0 - ftprim(6)=1.0d0/T0 - ftbis(6)=0.0d0 -#else - fT(6)=1.0d0 - ftprim(6)=0.0d0 - ftbis(6)=0.0d0 -#endif - else if (rescale_modeW.eq.2) then - quot=betaT/T0 - quotl=1.0d0 - do l=1,5 - quotl1=quotl - quotl=quotl*quot - eplus=dexp(quotl) - eminus=dexp(-quotl) - logfac=1.0d0/dlog(eplus+eminus) - tanhT=(eplus-eminus)/(eplus+eminus) - fT(l)=1.12692801104297249644d0*logfac - ftprim(l)=-l*quotl1*ft(l)*tanhT*logfac/T0 - ftbis(l)=(l-1)*ftprim(l)/(quot*T0)- & - 2*l*quotl1/T0*logfac* & - (2*l*quotl1*ft(l)/(T0*(eplus+eminus)**2) & - +ftprim(l)*tanhT) - enddo -#if defined(FUNCTH) - ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & - 320.0d0 - ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) - ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) & - /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) -#elif defined(FUNCT) - fT(6)=betaT/T0 - ftprim(6)=1.0d0/T0 - ftbis(6)=0.0d0 -#else - fT(6)=1.0d0 - ftprim(6)=0.0d0 - ftbis(6)=0.0d0 -#endif - else if (rescale_modeW.eq.0) then - do l=1,5 - fT(l)=1.0d0 - ftprim(l)=0.0d0 - enddo - else - write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE",& - rescale_modeW - call flush(iout) - return 1 - endif -! write (iout,*) "ftprim",ftprim -! write (iout,*) "ftbis",ftbis - betaT=1.0d0/(1.987D-3*betaT) -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & - +wvdwpp*evdw1 & - +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & - +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & - +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & - +ft(2)*wturn3*eello_turn3 & - +ft(5)*wturn6*eello_turn6+ft(2)*wel_loc*eel_loc & - +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & - +wbond*estr - eprim=ftprim(6)*evdw_t+ftprim(1)*welec*ees & - +ftprim(1)*wtor*etors+ & - ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ & - ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ & - ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eello_turn6+ & - ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ & - ftprim(1)*wsccor*esccor - ebis=ftbis(1)*welec*ees+ftbis(1)*wtor*etors+ & - ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ & - ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ & - ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eello_turn6+ & - ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ & - ftbis(1)*wsccor*esccor -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & - +ft(1)*welec*(ees+evdw1) & - +wang*ebe+ft(1)*wtor*etors+wscloc*escloc & - +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 & - +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 & - +ft(2)*wturn3*eello_turn3 & - +ft(5)*wturn6*eello_turn6+ft(2)*wel_loc*eel_loc+edihcnstr & - +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor & - +wbond*estr - eprim=ftprim(6)*evdw_t+ftprim(1)*welec*(ees+evdw1) & - +ftprim(1)*wtor*etors+ & - ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ & - ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ & - ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eello_turn6+ & - ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ & - ftprim(1)*wsccor*esccor - ebis=ftbis(1)*welec*(ees+evdw1)+ftbis(1)*wtor*etors+ & - ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ & - ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ & - ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eello_turn6+ & - ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ & - ftprim(1)*wsccor*esccor -#endif - weight=dexp(-betaT*(etot-potEmin)+entfac(t)) -#ifdef DEBUG - write (iout,*) "iparm",iparm," t",t," betaT",betaT,& - " etot",etot," entfac",entfac(t),& - " weight",weight," ebis",ebis -#endif - etot=etot-temper*eprim -#ifdef MPI - sumW_p(k,iparm)=sumW_p(k,iparm)+weight - sumE_p(k,iparm)=sumE_p(k,iparm)+etot*weight - sumEbis_p(k,iparm)=sumEbis_p(k,iparm)+ebis*weight - sumEsq_p(k,iparm)=sumEsq_p(k,iparm)+etot**2*weight - do j=1,nQ+2 - sumQ_p(j,k,iparm)=sumQ_p(j,k,iparm)+q(j,t)*weight - sumQsq_p(j,k,iparm)=sumQsq_p(j,k,iparm)+q(j,t)**2*weight - sumEQ_p(j,k,iparm)=sumEQ_p(j,k,iparm) & - +etot*q(j,t)*weight - enddo -#else - sumW(k,iparm)=sumW(k,iparm)+weight - sumE(k,iparm)=sumE(k,iparm)+etot*weight - sumEbis(k,iparm)=sumEbis(k,iparm)+ebis*weight - sumEsq(k,iparm)=sumEsq(k,iparm)+etot**2*weight - do j=1,nQ+2 - sumQ(j,k,iparm)=sumQ(j,k,iparm)+q(j,t)*weight - sumQsq(j,k,iparm)=sumQsq(j,k,iparm)+q(j,t)**2*weight - sumEQ(j,k,iparm)=sumEQ(j,k,iparm) & - +etot*q(j,t)*weight - enddo -#endif - enddo - indE = aint(potE(t,iparm)-aint(potEmin)) - if (indE.ge.0 .and. indE.le.maxinde) then - if (indE.gt.upindE_p) upindE_p=indE - histE_p(indE)=histE_p(indE)+dexp(-entfac(t)) - endif -#ifdef MPI - do ib=1,nT_h(iparm) - expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) - hfin_p(ind,ib)=hfin_p(ind,ib)+ & - dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) - if (rmsrgymap) then - indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) - indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) - hrmsrgy_p(indrgy,indrms,ib)= & - hrmsrgy_p(indrgy,indrms,ib)+expfac - endif - enddo -#else - do ib=1,nT_h(iparm) - expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) - hfin(ind,ib)=hfin(ind,ib)+ & - dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) - if (rmsrgymap) then - indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) - indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) - hrmsrgy(indrgy,indrms,ib)= & - hrmsrgy(indrgy,indrms,ib)+expfac - endif - enddo -#endif - enddo ! t - do ib=1,nT_h(iparm) - if (histout) call MPI_Reduce(hfin_p(0,ib),hfin(0,ib),nbin,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - if (rmsrgymap) then - call MPI_Reduce(hrmsrgy_p(0,0,ib),hrmsrgy(0,0,ib),& - (MaxBinRgy+1)*(nbin_rms+1),MPI_DOUBLE_PRECISION,MPI_SUM,Master,& - WHAM_COMM,IERROR) - endif - enddo - call MPI_Reduce(upindE_p,upindE,1,& - MPI_INTEGER,MPI_MAX,Master,WHAM_COMM,IERROR) - call MPI_Reduce(histE_p(0),histE(0),maxindE,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - - if (me1.eq.master) then - - if (histout) then - - write (iout,'(6x,$)') - write (iout,'(f20.2,$)') (1.0d0/(1.987D-3*beta_h(ib,iparm)),& - ib=1,nT_h(iparm)) - write (iout,*) - - write (iout,'(/a)') 'Final histograms' - if (histfile) then - if (nslice.eq.1) then - if (separate_parset) then - write(licz3,"(bz,i3.3)") myparm - histname=prefix(:ilen(prefix))//'_par'//licz3//'.hist' - else - histname=prefix(:ilen(prefix))//'.hist' - endif - else - if (separate_parset) then - write(licz3,"(bz,i3.3)") myparm - histname=prefix(:ilen(prefix))//'_par'//licz3// & - '_slice_'//licz2//'.hist' - else - histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.hist' - endif - endif -#if defined(AIX) || defined(PGI) - open (ihist,file=histname,position='append') -#else - open (ihist,file=histname,access='append') -#endif - endif - - do t=0,tmax - liczbaW=t - sumH=0.0d0 - do ib=1,nT_h(iparm) - sumH=sumH+hfin(t,ib) - enddo - if (sumH.gt.0.0d0) then - do j=1,nQ - jj = mod(liczbaW,nbin1) - liczbaW=liczbaW/nbin1 - write (iout,'(f6.3,$)') dmin+(jj+0.5d0)*delta - if (histfile) & - write (ihist,'(f6.3,$)') dmin+(jj+0.5d0)*delta - enddo - do ib=1,nT_h(iparm) - write (iout,'(e20.10,$)') hfin(t,ib) - if (histfile) write (ihist,'(e20.10,$)') hfin(t,ib) - enddo - write (iout,'(i5)') iparm - if (histfile) write (ihist,'(i5)') iparm - endif - enddo - - endif - - if (entfile) then - if (nslice.eq.1) then - if (separate_parset) then - write(licz3,"(bz,i3.3)") myparm - histname=prefix(:ilen(prefix))//"_par"//licz3//'.ent' - else - histname=prefix(:ilen(prefix))//'.ent' - endif - else - if (separate_parset) then - write(licz3,"(bz,i3.3)") myparm - histname=prefix(:ilen(prefix))//'par_'//licz3// & - '_slice_'//licz2//'.ent' - else - histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.ent' - endif - endif -#if defined(AIX) || defined(PGI) - open (ihist,file=histname,position='append') -#else - open (ihist,file=histname,access='append') -#endif - write (ihist,'(a)') "# Microcanonical entropy" - do i=0,upindE - write (ihist,'(f8.0,$)') dint(potEmin)+i - if (histE(i).gt.0.0e0) then - write (ihist,'(f15.5,$)') dlog(histE(i)) - else - write (ihist,'(f15.5,$)') 0.0d0 - endif - enddo - write (ihist,*) - close(ihist) - endif - write (iout,*) "Microcanonical entropy" - do i=0,upindE - write (iout,'(f8.0,$)') dint(potEmin)+i - if (histE(i).gt.0.0e0) then - write (iout,'(f15.5,$)') dlog(histE(i)) - else - write (iout,'(f15.5,$)') 0.0d0 - endif - write (iout,*) - enddo - if (rmsrgymap) then - if (nslice.eq.1) then - if (separate_parset) then - write(licz3,"(bz,i3.3)") myparm - histname=prefix(:ilen(prefix))//'_par'//licz3//'.rmsrgy' - else - histname=prefix(:ilen(prefix))//'.rmsrgy' - endif - else - if (separate_parset) then - write(licz3,"(bz,i3.3)") myparm - histname=prefix(:ilen(prefix))//'_par'//licz3// & - '_slice_'//licz2//'.rmsrgy' - else - histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.rmsrgy' - endif - endif -#if defined(AIX) || defined(PGI) - open (ihist,file=histname,position='append') -#else - open (ihist,file=histname,access='append') -#endif - do i=0,nbin_rms - do j=0,nbin_rgy - write(ihist,'(2f8.2,$)') & - rgymin+deltrgy*j,rmsmin+deltrms*i - do ib=1,nT_h(iparm) - if (hrmsrgy(j,i,ib).gt.0.0d0) then - write(ihist,'(e14.5,$)') & - -dlog(hrmsrgy(j,i,ib))/beta_h(ib,iparm) & - +potEmin - else - write(ihist,'(e14.5,$)') 1.0d6 - endif - enddo - write (ihist,'(i2)') iparm - enddo - enddo - close(ihist) - endif - endif - enddo ! iparm -#ifdef MPI - call MPI_Reduce(hfin_ent_p(0),hfin_ent(0),nbin,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - call MPI_Reduce(sumW_p(0,1),sumW(0,1),(nGridT+1)*nParmSet,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - call MPI_Reduce(sumE_p(0,1),sumE(0,1),(nGridT+1)*nParmSet,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - call MPI_Reduce(sumEbis_p(0,1),sumEbis(0,1),(nGridT+1)*nParmSet,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - call MPI_Reduce(sumEsq_p(0,1),sumEsq(0,1),(nGridT+1)*nParmSet,& - MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) - call MPI_Reduce(sumQ_p(1,0,1),sumQ(1,0,1),& - MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master,& - WHAM_COMM,IERROR) - call MPI_Reduce(sumQsq_p(1,0,1),sumQsq(1,0,1),& - MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master,& - WHAM_COMM,IERROR) - call MPI_Reduce(sumEQ_p(1,0,1),sumEQ(1,0,1),& - MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master,& - WHAM_COMM,IERROR) - if (me.eq.master) then -#endif - write (iout,'(/a)') 'Thermal characteristics of folding' - if (nslice.eq.1) then - nazwa=prefix - else - nazwa=prefix(:ilen(prefix))//"_slice_"//licz2 - endif - iln=ilen(nazwa) - if (nparmset.eq.1 .and. .not.separate_parset) then - nazwa=nazwa(:iln)//".thermal" - else if (nparmset.eq.1 .and. separate_parset) then - write(licz3,"(bz,i3.3)") myparm - nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" - endif - do iparm=1,nParmSet - if (nparmset.gt.1) then - write(licz3,"(bz,i3.3)") iparm - nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" - endif - open(34,file=nazwa) - if (separate_parset) then - write (iout,'(a,i3)') "Parameter set",myparm - else - write (iout,'(a,i3)') "Parameter set",iparm - endif - do i=0,NGridT - sumE(i,iparm)=sumE(i,iparm)/sumW(i,iparm) - sumEbis(i,iparm)=(startGridT+i*delta_T)*sumEbis(i,iparm)/ & - sumW(i,iparm) - sumEsq(i,iparm)=(sumEsq(i,iparm)/sumW(i,iparm) & - -sumE(i,iparm)**2)/(1.987D-3*(startGridT+i*delta_T)**2) - do j=1,nQ+2 - sumQ(j,i,iparm)=sumQ(j,i,iparm)/sumW(i,iparm) - sumQsq(j,i,iparm)=sumQsq(j,i,iparm)/sumW(i,iparm) & - -sumQ(j,i,iparm)**2 - sumEQ(j,i,iparm)=sumEQ(j,i,iparm)/sumW(i,iparm) & - -sumQ(j,i,iparm)*sumE(i,iparm) - enddo - sumW(i,iparm)=-dlog(sumW(i,iparm))*(1.987D-3* & - (startGridT+i*delta_T))+potEmin - write (iout,'(f7.1,2f15.5,$)') startGridT+i*delta_T,& - sumW(i,iparm),sumE(i,iparm) - write (iout,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) - write (iout,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm),& - (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) - write (iout,*) - write (34,'(f7.1,2f15.5,$)') startGridT+i*delta_T,& - sumW(i,iparm),sumE(i,iparm) - write (34,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) - write (34,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm),& - (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) - write (34,*) - call flush(34) - enddo - close(34) - enddo - if (histout) then - do t=0,tmax - if (hfin_ent(t).gt.0.0d0) then - liczbaW=t - jj = mod(liczbaW,nbin1) - write (iout,'(f6.3,e20.10," ent")') dmin+(jj+0.5d0)*delta,& - hfin_ent(t) - if (histfile) write (ihist,'(f6.3,e20.10," ent")') & - dmin+(jj+0.5d0)*delta,& - hfin_ent(t) - endif - enddo - if (histfile) close(ihist) - endif - -#ifdef ZSCORE -! Write data for zscore - if (nslice.eq.1) then - zscname=prefix(:ilen(prefix))//".zsc" - else - zscname=prefix(:ilen(prefix))//"_slice_"//licz2//".zsc" - endif -#if defined(AIX) || defined(PGI) - open (izsc,file=prefix(:ilen(prefix))//'.zsc',position='append') -#else - open (izsc,file=prefix(:ilen(prefix))//'.zsc',access='append') -#endif - write (izsc,'("NQ=",i1," NPARM=",i1)') nQ,nParmSet - do iparm=1,nParmSet - write (izsc,'("NT=",i1)') nT_h(iparm) - do ib=1,nT_h(iparm) - write (izsc,'("TEMP=",f6.1," NR=",i2," SNK=",$)') & - 1.0d0/(beta_h(ib,iparm)*1.987D-3),nR(ib,iparm) - jj = min0(nR(ib,iparm),7) - write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=1,jj) - write (izsc,'(a1,$)') (" ",i=22+8*jj+1,79) - write (izsc,'("&")') - if (nR(ib,iparm).gt.7) then - do ii=8,nR(ib,iparm),9 - jj = min0(nR(ib,iparm),ii+8) - write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=ii,jj) - write (izsc,'(a1,$') (" ",i=(jj-ii+1)*8+1,79) - write (izsc,'("&")') - enddo - endif - write (izsc,'("FI=",$)') - jj=min0(nR(ib,iparm),7) - write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=1,jj) - write (izsc,'(a1,$)') (" ",i=3+10*jj+1,79) - write (izsc,'("&")') - if (nR(ib,iparm).gt.7) then - do ii=8,nR(ib,iparm),9 - jj = min0(nR(ib,iparm),ii+8) - write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=ii,jj) - if (jj.eq.nR(ib,iparm)) then - write (izsc,*) - else - write (izsc,'(a1,$)') (" ",i=10*(jj-ii+1)+1,79) - write (izsc,'(t80,"&")') - endif - enddo - endif - do i=1,nR(ib,iparm) - write (izsc,'("KH=",$)') - write (izsc,'(f7.2,$)') (Kh(j,i,ib,iparm),j=1,nQ) - write (izsc,'(" Q0=",$)') - write (izsc,'(f7.5,$)') (q0(j,i,ib,iparm),j=1,nQ) - write (izsc,*) - enddo - enddo - enddo - close(izsc) -#endif -#ifdef MPI - endif -#endif - return - end subroutine WHAMCALC -!----------------------------------------------------------------------------- - end module wham_calc - diff --git a/source/wham/wham_data.F90 b/source/wham/wham_data.F90 new file mode 100644 index 0000000..1dfc3bc --- /dev/null +++ b/source/wham/wham_data.F90 @@ -0,0 +1,132 @@ + module wham_data +!--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- + integer,parameter :: max_eneW=21 + integer,parameter :: maxQ=1 + integer,parameter :: maxQ1=MaxQ+2 + integer,parameter :: max_parm=1 + integer,parameter :: MaxSlice=40 + integer,parameter :: MaxN=100 + integer,parameter :: MaxR=1 + integer,parameter :: MaxT_h=32 + integer,parameter :: maxstr=200000 + integer,parameter :: maxfile_prot=100 +! Maximum number of structures to be dealt with by one processor + integer,parameter :: maxstr_proc=10000 + integer :: n_eneW + integer :: ijunk +!--------------------------------------------------------------------------- + +!--------------------------------------------------------------------------- +! DIMENSIONS.COMPAR +! Array dimensions for level-based conformation comparison program: +! +! Max. number of conformations in the data set. +! +! integer maxconf +! PARAMETER (MAXCONF=maxstr_proc) +! +! Max. number levels of comparison +! +! integer maxlevel +! PARAMETER (MAXLEVEL=3) +! +! Max. number of fragments at a given level of comparison +! + integer,parameter :: maxfrag=30 + integer,parameter :: MMAXFRAG=MAXFRAG*(MAXFRAG+1)/2 +! +! Max. number of pieces forming a substructure to be compared +! + integer,parameter :: MAXPIECE=20 +! +!--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- +! COMMON.WEIGHTS +! common /chujec/ + real(kind=8),dimension(:),allocatable :: ww,ww0,ww_low,ww_up,& + ww_orig !(max_ene) + real(kind=8),dimension(:),allocatable :: x_orig,x_up,x_low !(max_paropt) + real(kind=8),dimension(2,2) :: epp_low,epp_up,rpp_low,rpp_up,& + elpp6_low,elpp6_up,elpp3_low,elpp3_up + real(kind=8),dimension(13,3) :: b_low,b_up + real(kind=8),dimension(:,:),allocatable :: epscp_low,epscp_up,& + rscp_low,rscp_up !(0:ntyp,2) + real(kind=8),dimension(:),allocatable :: epss_low,epss_up !(ntyp) + real(kind=8),dimension(:),allocatable :: epsp_low,epsp_up !(nntyp) + real(kind=8),dimension(:,:),allocatable :: xm,xm1,& + xm2 !(max_paropt,0:maxprot) + + integer,dimension(:),allocatable :: imask,iwW !(max_ene) + integer :: nsingle_sc,npair_sc + integer,dimension(:),allocatable :: ityp_ssc !(ntyp) + integer,dimension(:,:),allocatable :: ityp_psc !(2,nntyp) + integer :: mask_elec(2,2,4),mask_fourier(13,3),mod_fourier(0:3) + integer,dimension(:,:,:),allocatable :: mask_scp !(0:ntyp,2,2) + integer,dimension(:,:),allocatable :: indz !(maxbatch+1,maxprot) + logical :: mod_other_params,mod_elec,mod_scp,mod_side +!--------------------------------------------------------------------------- +! COMMON.FREE +! common /wham/ + integer :: nQ,nparmset,rescale_modeW,iparmprint,myparm + integer,dimension(:),allocatable :: stot !(maxslice) + logical :: hamil_rep,separate_parset + real(kind=8),dimension(:,:,:,:),allocatable :: Kh,q0 !(MaxQ,MaxR,MaxT_h,max_parm) + real(kind=8) :: delta,deltrms,deltrgy,fimin + real(kind=8),dimension(:,:,:),allocatable :: f !(maxR,maxT_h,max_parm) + real(kind=8),dimension(:,:),allocatable :: beta_h !(MaxT_h,max_parm) + integer,dimension(:,:),allocatable :: nR,nRR !(maxT_h,max_parm) + integer,dimension(:,:,:,:),allocatable :: snk !(MaxR,MaxT_h,max_parm,MaxSlice) + integer,dimension(:),allocatable :: nT_h !(max_parm) + integer :: maxit + integer,dimension(:,:),allocatable :: totraj !(maxR,max_parm) + logical,dimension(:),allocatable :: replica,umbrella,read_iset !(max_parm) +!--------------------------------------------------------------------------- +! COMMON.PROT +! common /protein/ + integer,dimension(:),allocatable :: ntot !(maxslice) + integer,dimension(:),allocatable :: isampl !(max_parm) + integer :: nslice +!--------------------------------------------------------------------------- +! COMMON.PROTFILES +! common /protfil/ + character(len=80),dimension(:,:,:,:,:),allocatable :: protfiles !(maxfile_prot,2,MaxR,MaxT_h,Max_Parm) + character(len=80) :: bprotfiles + integer,dimension(:,:,:),allocatable :: nfile_bin,nfile_asc,& + nfile_cx,rec_start,rec_end !(MaxR,MaxT_h,Max_Parm) + integer :: lenrec,lenrec1,lenrec2 +!--------------------------------------------------------------------------- +! COMMON.ENERGIES +! common /energies/ + real(kind=8),dimension(:,:),allocatable :: potE !(MaxStr_Proc,Max_Parm) + real(kind=8),dimension(:),allocatable :: entfac !(MaxStr_Proc) + real(kind=8),dimension(:,:),allocatable :: q !(MaxQ+2,MaxStr_Proc) + real(kind=8),dimension(:,:,:),allocatable :: enetb !(max_ene,MaxStr_Proc,Max_Parm) + integer :: einicheck +!--------------------------------------------------------------------------- +! COMMON.CONTROL +! common /cntrl/ + logical :: punch_dist,print_rms,caonly,verbose,merge_helices,& + bxfile,cxfile,histfile,entfile,zscfile,rmsrgymap,& + with_dihed_constr,check_conf,histout + integer :: icomparfunc,pdbint,ensembles,constr_dist +!--------------------------------------------------------------------------- +! COMMON.OBCINKA +! common /obcinka/ + real(kind=8),dimension(:,:,:),allocatable :: time_start_collect,& + time_end_collect !(maxR,MaxT_h,Max_Parm) +!--------------------------------------------------------------------------- +! COMMON.PEPTCONT +! common /peptcont/ + integer :: ncont_pept_ref + integer,dimension(:,:),allocatable :: icont_pept_ref !(2,maxcont) + integer,dimension(:),allocatable :: ncont_frag_ref !(mmaxfrag) + integer,dimension(:,:,:),allocatable :: icont_frag_ref !(2,maxcont,mmaxfrag) + integer,dimension(:),allocatable :: isec_ref !(maxres) +!--------------------------------------------------------------------------- +! COMMON.CONTPAR +! common /contpar/ +! real(kind=8),dimension(:,:),allocatable :: sig_comp,chi_comp,& +! chip_comp,sc_cutoff !(ntyp,ntyp) +!--------------------------------------------------------------------------- + end module wham_data diff --git a/source/wham/wham_data.f90 b/source/wham/wham_data.f90 deleted file mode 100644 index 1dfc3bc..0000000 --- a/source/wham/wham_data.f90 +++ /dev/null @@ -1,132 +0,0 @@ - module wham_data -!--------------------------------------------------------------------------- -!--------------------------------------------------------------------------- - integer,parameter :: max_eneW=21 - integer,parameter :: maxQ=1 - integer,parameter :: maxQ1=MaxQ+2 - integer,parameter :: max_parm=1 - integer,parameter :: MaxSlice=40 - integer,parameter :: MaxN=100 - integer,parameter :: MaxR=1 - integer,parameter :: MaxT_h=32 - integer,parameter :: maxstr=200000 - integer,parameter :: maxfile_prot=100 -! Maximum number of structures to be dealt with by one processor - integer,parameter :: maxstr_proc=10000 - integer :: n_eneW - integer :: ijunk -!--------------------------------------------------------------------------- - -!--------------------------------------------------------------------------- -! DIMENSIONS.COMPAR -! Array dimensions for level-based conformation comparison program: -! -! Max. number of conformations in the data set. -! -! integer maxconf -! PARAMETER (MAXCONF=maxstr_proc) -! -! Max. number levels of comparison -! -! integer maxlevel -! PARAMETER (MAXLEVEL=3) -! -! Max. number of fragments at a given level of comparison -! - integer,parameter :: maxfrag=30 - integer,parameter :: MMAXFRAG=MAXFRAG*(MAXFRAG+1)/2 -! -! Max. number of pieces forming a substructure to be compared -! - integer,parameter :: MAXPIECE=20 -! -!--------------------------------------------------------------------------- -!--------------------------------------------------------------------------- -! COMMON.WEIGHTS -! common /chujec/ - real(kind=8),dimension(:),allocatable :: ww,ww0,ww_low,ww_up,& - ww_orig !(max_ene) - real(kind=8),dimension(:),allocatable :: x_orig,x_up,x_low !(max_paropt) - real(kind=8),dimension(2,2) :: epp_low,epp_up,rpp_low,rpp_up,& - elpp6_low,elpp6_up,elpp3_low,elpp3_up - real(kind=8),dimension(13,3) :: b_low,b_up - real(kind=8),dimension(:,:),allocatable :: epscp_low,epscp_up,& - rscp_low,rscp_up !(0:ntyp,2) - real(kind=8),dimension(:),allocatable :: epss_low,epss_up !(ntyp) - real(kind=8),dimension(:),allocatable :: epsp_low,epsp_up !(nntyp) - real(kind=8),dimension(:,:),allocatable :: xm,xm1,& - xm2 !(max_paropt,0:maxprot) - - integer,dimension(:),allocatable :: imask,iwW !(max_ene) - integer :: nsingle_sc,npair_sc - integer,dimension(:),allocatable :: ityp_ssc !(ntyp) - integer,dimension(:,:),allocatable :: ityp_psc !(2,nntyp) - integer :: mask_elec(2,2,4),mask_fourier(13,3),mod_fourier(0:3) - integer,dimension(:,:,:),allocatable :: mask_scp !(0:ntyp,2,2) - integer,dimension(:,:),allocatable :: indz !(maxbatch+1,maxprot) - logical :: mod_other_params,mod_elec,mod_scp,mod_side -!--------------------------------------------------------------------------- -! COMMON.FREE -! common /wham/ - integer :: nQ,nparmset,rescale_modeW,iparmprint,myparm - integer,dimension(:),allocatable :: stot !(maxslice) - logical :: hamil_rep,separate_parset - real(kind=8),dimension(:,:,:,:),allocatable :: Kh,q0 !(MaxQ,MaxR,MaxT_h,max_parm) - real(kind=8) :: delta,deltrms,deltrgy,fimin - real(kind=8),dimension(:,:,:),allocatable :: f !(maxR,maxT_h,max_parm) - real(kind=8),dimension(:,:),allocatable :: beta_h !(MaxT_h,max_parm) - integer,dimension(:,:),allocatable :: nR,nRR !(maxT_h,max_parm) - integer,dimension(:,:,:,:),allocatable :: snk !(MaxR,MaxT_h,max_parm,MaxSlice) - integer,dimension(:),allocatable :: nT_h !(max_parm) - integer :: maxit - integer,dimension(:,:),allocatable :: totraj !(maxR,max_parm) - logical,dimension(:),allocatable :: replica,umbrella,read_iset !(max_parm) -!--------------------------------------------------------------------------- -! COMMON.PROT -! common /protein/ - integer,dimension(:),allocatable :: ntot !(maxslice) - integer,dimension(:),allocatable :: isampl !(max_parm) - integer :: nslice -!--------------------------------------------------------------------------- -! COMMON.PROTFILES -! common /protfil/ - character(len=80),dimension(:,:,:,:,:),allocatable :: protfiles !(maxfile_prot,2,MaxR,MaxT_h,Max_Parm) - character(len=80) :: bprotfiles - integer,dimension(:,:,:),allocatable :: nfile_bin,nfile_asc,& - nfile_cx,rec_start,rec_end !(MaxR,MaxT_h,Max_Parm) - integer :: lenrec,lenrec1,lenrec2 -!--------------------------------------------------------------------------- -! COMMON.ENERGIES -! common /energies/ - real(kind=8),dimension(:,:),allocatable :: potE !(MaxStr_Proc,Max_Parm) - real(kind=8),dimension(:),allocatable :: entfac !(MaxStr_Proc) - real(kind=8),dimension(:,:),allocatable :: q !(MaxQ+2,MaxStr_Proc) - real(kind=8),dimension(:,:,:),allocatable :: enetb !(max_ene,MaxStr_Proc,Max_Parm) - integer :: einicheck -!--------------------------------------------------------------------------- -! COMMON.CONTROL -! common /cntrl/ - logical :: punch_dist,print_rms,caonly,verbose,merge_helices,& - bxfile,cxfile,histfile,entfile,zscfile,rmsrgymap,& - with_dihed_constr,check_conf,histout - integer :: icomparfunc,pdbint,ensembles,constr_dist -!--------------------------------------------------------------------------- -! COMMON.OBCINKA -! common /obcinka/ - real(kind=8),dimension(:,:,:),allocatable :: time_start_collect,& - time_end_collect !(maxR,MaxT_h,Max_Parm) -!--------------------------------------------------------------------------- -! COMMON.PEPTCONT -! common /peptcont/ - integer :: ncont_pept_ref - integer,dimension(:,:),allocatable :: icont_pept_ref !(2,maxcont) - integer,dimension(:),allocatable :: ncont_frag_ref !(mmaxfrag) - integer,dimension(:,:,:),allocatable :: icont_frag_ref !(2,maxcont,mmaxfrag) - integer,dimension(:),allocatable :: isec_ref !(maxres) -!--------------------------------------------------------------------------- -! COMMON.CONTPAR -! common /contpar/ -! real(kind=8),dimension(:,:),allocatable :: sig_comp,chi_comp,& -! chip_comp,sc_cutoff !(ntyp,ntyp) -!--------------------------------------------------------------------------- - end module wham_data diff --git a/source/wham/work_partition.F90 b/source/wham/work_partition.F90 new file mode 100644 index 0000000..a50da8e --- /dev/null +++ b/source/wham/work_partition.F90 @@ -0,0 +1,127 @@ + module work_part +!------------------------------------------------------------------------------ + use io_units + use MPI_data + use wham_data + implicit none +#ifdef MPI +!------------------------------------------------------------------------------ +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +#ifdef CLUSTER + subroutine work_partition(lprint,ncon_work) +#else + subroutine work_partition(islice,lprint) +#endif +! Split the conformations between processors +! implicit none +! include "DIMENSIONS" +! include "DIMENSIONS.ZSCOPT" +! include "DIMENSIONS.FREE" + include "mpif.h" +! include "COMMON.IOUNITS" +! include "COMMON.MPI" +! include "COMMON.PROT" + integer :: islice,ncon_work + integer :: n,chunk,i,j,ii,remainder +!el integer :: kolor + integer :: key,ierror,errcode + logical :: lprint +! +! Divide conformations between processors; the first and +! the last conformation to handle by ith processor is stored in +! indstart(i) and indend(i), respectively. +! +!el MPI_data + if (.not. allocated(indstart)) allocate(indstart(0:nprocs)) + if (.not. allocated(indend)) allocate(indend(0:nprocs)) + if (.not. allocated(idispl)) allocate(idispl(0:nprocs)) + if (.not. allocated(scount)) allocate(scount(0:nprocs)) +! First try to assign equal number of conformations to each processor. +! +#ifdef CLUSTER + n=ncon_work + write (iout,*) "n=",n," nprocs=",nprocs + nprocs1=nprocs +#else + n=ntot(islice) + write (iout,*) "n=",n +#endif + indstart(0)=1 + chunk = N/nprocs1 + scount(0) = chunk +write(iout,*)"chunk",chunk,scount(0) +flush(iout) +! print *,"i",0," indstart",indstart(0)," scount",& +! scount(0) + do i=1,nprocs1-1 + indstart(i)=chunk+indstart(i-1) + scount(i)=scount(i-1) +! print *,"i",i," indstart",indstart(i)," scount", +! & scount(i) + enddo +! +! Determine how many conformations remained yet unassigned. +! + remainder=N-(indstart(nprocs1-1) & + +scount(nprocs1-1)-1) +! print *,"remainder",remainder +! +! Assign the remainder conformations to consecutive processors, starting +! from the lowest rank; this continues until the list is exhausted. +! + if (remainder .gt. 0) then + do i=1,remainder + scount(i-1) = scount(i-1) + 1 + indstart(i) = indstart(i) + i + enddo + do i=remainder+1,nprocs1-1 + indstart(i) = indstart(i) + remainder + enddo + endif + + indstart(nprocs1)=N+1 + scount(nprocs1)=0 + + do i=0,NProcs1 + indend(i)=indstart(i)+scount(i)-1 + idispl(i)=indstart(i)-1 + enddo + + N=0 + do i=0,Nprocs1-1 + N=N+indend(i)-indstart(i)+1 + enddo + +! print *,"N",n," NTOT",ntot(islice) +#ifdef CLUSTER + if (N.ne.ncon_work) then + write (iout,*) "!!! Checksum error on processor",me,& + n,ncon_work +#else + if (N.ne.ntot(islice)) then + write (iout,*) "!!! Checksum error on processor",me,& + " slice",islice +#endif + call flush(iout) + call MPI_Abort( MPI_COMM_WORLD, Ierror, Errcode ) + endif + + if (lprint) then + write (iout,*) "Partition of work between processors" + do i=0,nprocs1-1 + write (iout,'(a,i5,a,i7,a,i7,a,i7)') & + "Processor",i," indstart",indstart(i),& + " indend",indend(i)," count",scount(i) + enddo + endif + return + end subroutine work_partition +#endif +!---------------------------------------------------------------------------- + end module work_part +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- diff --git a/source/wham/work_partition.f90 b/source/wham/work_partition.f90 deleted file mode 100644 index a50da8e..0000000 --- a/source/wham/work_partition.f90 +++ /dev/null @@ -1,127 +0,0 @@ - module work_part -!------------------------------------------------------------------------------ - use io_units - use MPI_data - use wham_data - implicit none -#ifdef MPI -!------------------------------------------------------------------------------ -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -#ifdef CLUSTER - subroutine work_partition(lprint,ncon_work) -#else - subroutine work_partition(islice,lprint) -#endif -! Split the conformations between processors -! implicit none -! include "DIMENSIONS" -! include "DIMENSIONS.ZSCOPT" -! include "DIMENSIONS.FREE" - include "mpif.h" -! include "COMMON.IOUNITS" -! include "COMMON.MPI" -! include "COMMON.PROT" - integer :: islice,ncon_work - integer :: n,chunk,i,j,ii,remainder -!el integer :: kolor - integer :: key,ierror,errcode - logical :: lprint -! -! Divide conformations between processors; the first and -! the last conformation to handle by ith processor is stored in -! indstart(i) and indend(i), respectively. -! -!el MPI_data - if (.not. allocated(indstart)) allocate(indstart(0:nprocs)) - if (.not. allocated(indend)) allocate(indend(0:nprocs)) - if (.not. allocated(idispl)) allocate(idispl(0:nprocs)) - if (.not. allocated(scount)) allocate(scount(0:nprocs)) -! First try to assign equal number of conformations to each processor. -! -#ifdef CLUSTER - n=ncon_work - write (iout,*) "n=",n," nprocs=",nprocs - nprocs1=nprocs -#else - n=ntot(islice) - write (iout,*) "n=",n -#endif - indstart(0)=1 - chunk = N/nprocs1 - scount(0) = chunk -write(iout,*)"chunk",chunk,scount(0) -flush(iout) -! print *,"i",0," indstart",indstart(0)," scount",& -! scount(0) - do i=1,nprocs1-1 - indstart(i)=chunk+indstart(i-1) - scount(i)=scount(i-1) -! print *,"i",i," indstart",indstart(i)," scount", -! & scount(i) - enddo -! -! Determine how many conformations remained yet unassigned. -! - remainder=N-(indstart(nprocs1-1) & - +scount(nprocs1-1)-1) -! print *,"remainder",remainder -! -! Assign the remainder conformations to consecutive processors, starting -! from the lowest rank; this continues until the list is exhausted. -! - if (remainder .gt. 0) then - do i=1,remainder - scount(i-1) = scount(i-1) + 1 - indstart(i) = indstart(i) + i - enddo - do i=remainder+1,nprocs1-1 - indstart(i) = indstart(i) + remainder - enddo - endif - - indstart(nprocs1)=N+1 - scount(nprocs1)=0 - - do i=0,NProcs1 - indend(i)=indstart(i)+scount(i)-1 - idispl(i)=indstart(i)-1 - enddo - - N=0 - do i=0,Nprocs1-1 - N=N+indend(i)-indstart(i)+1 - enddo - -! print *,"N",n," NTOT",ntot(islice) -#ifdef CLUSTER - if (N.ne.ncon_work) then - write (iout,*) "!!! Checksum error on processor",me,& - n,ncon_work -#else - if (N.ne.ntot(islice)) then - write (iout,*) "!!! Checksum error on processor",me,& - " slice",islice -#endif - call flush(iout) - call MPI_Abort( MPI_COMM_WORLD, Ierror, Errcode ) - endif - - if (lprint) then - write (iout,*) "Partition of work between processors" - do i=0,nprocs1-1 - write (iout,'(a,i5,a,i7,a,i7,a,i7)') & - "Processor",i," indstart",indstart(i),& - " indend",indend(i)," count",scount(i) - enddo - endif - return - end subroutine work_partition -#endif -!---------------------------------------------------------------------------- - end module work_part -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -- 1.7.9.5